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

Merge branch 'master' of https://git.avsdev.uk/JNCC/MESO

Browse Source
This commit is contained in:
Steve Pegg
2022-04-07 10:21:06 +01:00
parent d0b16ea155 99fa481fcb
commit 54b10db159
4 changed files with 489 additions and 554 deletions
Download Patch File Download Diff File Expand all files Collapse all files

137
Parses.R
View File

@@ -5,7 +5,7 @@ modules::import(stringr)
modules::import(stats) modules::import(stats)
#Improvements needed: make the selection of first row/column of nodes programmatic # Improvements needed: make the selection of first row/column of nodes programmatic
FIRST_NODE_COL <- 3 FIRST_NODE_COL <- 3
mappings <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend") mappings <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend")
@@ -22,7 +22,7 @@ setEmpties <- function(val) {
} }
readXL <- function(fName, sheetN, startRow = 1) { readXL <- function(fName, sheetN, startRow = 1) {
xl <- read.xlsx(fName, sheet = sheetN, startRow) #, rowNames = import) xl <- read.xlsx(fName, sheet = sheetN, startRow) # , rowNames = import)
return(data.frame(xl, stringsAsFactors = FALSE, row.names = NULL)) return(data.frame(xl, stringsAsFactors = FALSE, row.names = NULL))
} }
@@ -31,7 +31,7 @@ delNA <- function(vec) {
} }
buildExpr <- function(pressStatus) { buildExpr <- function(pressStatus) {
#pressStatus is a two column DF of name of pressure and status Ii.e. on or off) # pressStatus is a two column DF of name of pressure and status Ii.e. on or off)
MEANPRESS <- 0 MEANPRESS <- 0
expr <- "(" expr <- "("
for (p in 1:nrow(pressStatus)) { for (p in 1:nrow(pressStatus)) {
@@ -57,10 +57,13 @@ parseScenario <- function(press, prefix = "p") {
ncol = 3, ncol = 3,
dimnames = list(NULL, c("growth", "confidence", "layer")) dimnames = list(NULL, c("growth", "confidence", "layer"))
) )
for (col in 2:ncol(press)) { for (col in 2:ncol(press)) {
coefs[col-1,] <- as.numeric(split(press[1, col]))[match(c("growth", "confidence", "layer"), states)] coefs[col - 1, ] <- as.numeric(split(press[1, col]))[match(c("growth", "confidence", "layer"), states)]
} }
press[is.na(press)] <- 0 press[is.na(press)] <- 0
if (sum(duplicated(pressNames)) > 0) { if (sum(duplicated(pressNames)) > 0) {
cat("Duplicated pressure node names found") cat("Duplicated pressure node names found")
print(pressNodes[duplicated(pressNames)]) print(pressNodes[duplicated(pressNames)])
@@ -71,9 +74,9 @@ parseScenario <- function(press, prefix = "p") {
nodes = data.frame( nodes = data.frame(
name = pressNames, name = pressNames,
code = paste0(prefix, seq(1:length(pressNames))), code = paste0(prefix, seq(1:length(pressNames))),
growth = coefs[,"growth"], growth = coefs[, "growth"],
confidence = coefs[,"confidence"], confidence = coefs[, "confidence"],
layer = coefs[,"layer"], layer = coefs[, "layer"],
stringsAsFactors = FALSE stringsAsFactors = FALSE
), ),
edges = data.frame(input = NULL, output = NULL, impact = NULL) edges = data.frame(input = NULL, output = NULL, impact = NULL)
@@ -85,7 +88,6 @@ getInitial <- function(string, letter) {
} }
split <- function(cell) { split <- function(cell) {
params <- unlist(strsplit(cell, ",")) params <- unlist(strsplit(cell, ","))
values <- rep(0, length(states)) values <- rep(0, length(states))
@@ -96,7 +98,7 @@ split <- function(cell) {
if ((ref > 0) & (ref <= length(values))) { if ((ref > 0) & (ref <= length(values))) {
values[ref] <- kvp[2] values[ref] <- kvp[2]
} else { } else {
print(paste("Unrecognised parameter(s):",params[n])) print(paste("Unrecognised parameter(s):", params[n]))
} }
} }
@@ -118,19 +120,17 @@ getOutNodes <- function(codes, codeList) {
} }
buildGraph <- function(model, desc) { buildGraph <- function(model, desc) {
# model contains the following
#model contains the following
# node table, edge table # node table, edge table
#descriptor (desc) contains: # descriptor (desc) contains:
#inputCode - the top layer of the model # inputCode - the top layer of the model
#outputCodes - all subsequent layers to be included in the model # outputCodes - all subsequent layers to be included in the model
inputNodes <- model$nodes$code[which(startsWith(model$nodes$code, desc$inputCode))] inputNodes <- model$nodes$code[which(startsWith(model$nodes$code, desc$inputCode))]
inputText <- paste0("[", inputNodes, "]", collapse = "") inputText <- paste0("[", inputNodes, "]", collapse = "")
#do the internal nodes # do the internal nodes
edges <- "" edges <- ""
outNodes <- model$nodes$code[getOutNodes(model$nodes$code, desc$outputCodes)] outNodes <- model$nodes$code[getOutNodes(model$nodes$code, desc$outputCodes)]
@@ -141,26 +141,19 @@ buildGraph <- function(model, desc) {
rows <- which(model$edges$output == outNodes[idx]) rows <- which(model$edges$output == outNodes[idx])
inputsStr <- paste0(model$edges$input[which(model$edges$output == outNodes[idx])], sep = ":", collapse = "") inputsStr <- paste0(model$edges$input[which(model$edges$output == outNodes[idx])], sep = ":", collapse = "")
edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start = 1, stop = (nchar(inputsStr)-1)), "]")) edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start = 1, stop = (nchar(inputsStr) - 1)), "]"))
#Make the coefficient of the distribution # Make the coefficient of the distribution
coefVal <- setNames( coefVal <- setNames(
c(model$nodes$growth[nodeRef], model$edges$values[rows]), c(model$nodes$growth[nodeRef], model$edges$values[rows]),
c("(Intercept)", model$edges$input[rows]) c("(Intercept)", model$edges$input[rows])
) )
#str(coefVal)
outDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[nodeRef]) outDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[nodeRef])
} }
print("Saving model prior to network modelling") print("Saving model prior to network modelling")
modelDefn <- paste0(inputText, edges) modelDefn <- paste0(inputText, edges)
save(modelDefn, file="buildGraph.RData")
#print("about to build network")
#print(paste0(inputText, edges))
net <- model2network(paste0(inputText, edges), debug = FALSE) net <- model2network(paste0(inputText, edges), debug = FALSE)
@@ -176,15 +169,12 @@ buildGraph <- function(model, desc) {
allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes))) allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes)))
#print(allDists)
cfit <- custom.fit(net, allDists) cfit <- custom.fit(net, allDists)
cat("about to calculate sample distributions") print("about to calculate sample distributions")
#print(outNodes)
sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw") sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw")
summDists <- summary(sampleDists) summDists <- summary(sampleDists)
#stdDev <- sd(sampleDists)
print("sample distribution build successful") print("sample distribution build successful")
@@ -205,12 +195,11 @@ buildGraph <- function(model, desc) {
getValidNodes <- function(mapping, prevOutputs, prefix) { getValidNodes <- function(mapping, prevOutputs, prefix) {
# Find row id for input nodes, internal and published
inputNodes <- mapping[2:nrow(mapping), 1]
#Find row id for input nodes, internal and published # check that all input nodes are in the previous table
inputNodes <- mapping[2:nrow(mapping),1] inputNodes <- delNA(mapping[mapping[, "Node.Type"] == "input", "Nodes"])
#check that all input nodes are in the previous table
inputNodes <- delNA(mapping[mapping[,"Node.Type"] == "input", "Nodes"])
if (length(inputNodes) > 0) { if (length(inputNodes) > 0) {
if (sum(inputNodes %in% prevOutputs$name) < length(inputNodes)) { if (sum(inputNodes %in% prevOutputs$name) < length(inputNodes)) {
cat("Missing entries for input nodes in previous output columns") cat("Missing entries for input nodes in previous output columns")
@@ -221,7 +210,7 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
} }
#Check the row headings concur with previous names # Check the row headings concur with previous names
validInputs <- delNA(inputNodes[which(unique(inputNodes) %in% prevOutputs$name)]) validInputs <- delNA(inputNodes[which(unique(inputNodes) %in% prevOutputs$name)])
if (length(validInputs) == 0) { if (length(validInputs) == 0) {
print("Invalid sheet - table must have at least one input row containing names from previous table") print("Invalid sheet - table must have at least one input row containing names from previous table")
@@ -230,7 +219,7 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
inputInts <- delNA(inputNodes[mapping$Node.Type != "link"]) inputInts <- delNA(inputNodes[mapping$Node.Type != "link"])
if (sum(duplicated(inputInts))>0) { if (sum(duplicated(inputInts)) > 0) {
cat("Duplicated input node names found") cat("Duplicated input node names found")
print(inputNodes[duplicated(inputNodes)]) print(inputNodes[duplicated(inputNodes)])
} }
@@ -242,10 +231,10 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
} }
#check that all internal nodes are in the columns # check that all internal nodes are in the columns
intNodes <- delNA(mapping[mapping[,"Node.Type"] == "internal", "Nodes"]) intNodes <- delNA(mapping[mapping[, "Node.Type"] == "internal", "Nodes"])
if (length(intNodes) > 0) { if (length(intNodes) > 0) {
if (sum(intNodes %in% outNodes)<length(intNodes)) { if (sum(intNodes %in% outNodes) < length(intNodes)) {
cat("Missing entries for internal nodes in output columns") cat("Missing entries for internal nodes in output columns")
print(intNodes[!(intNodes %in% outNodes)]) print(intNodes[!(intNodes %in% outNodes)])
} }
@@ -254,15 +243,15 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
coefs <- matrix(data = NA, nrow = length(outNodes), ncol = 3, dimnames = list(NULL, c("growth", "confidence", "layer"))) coefs <- matrix(data = NA, nrow = length(outNodes), ncol = 3, dimnames = list(NULL, c("growth", "confidence", "layer")))
for (idx in 1:length(outNodes)) { for (idx in 1:length(outNodes)) {
col <- match(outNodes[idx], colnames(mapping)) col <- match(outNodes[idx], colnames(mapping))
coefs[idx,] <- as.numeric(split(mapping[1, col]))[match(c("growth", "confidence", "layer"), states)] coefs[idx, ] <- as.numeric(split(mapping[1, col]))[match(c("growth", "confidence", "layer"), states)]
} }
return(data.frame( return(data.frame(
code = c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))), code = c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))),
name = c(prevOutputs$name, outNodes), name = c(prevOutputs$name, outNodes),
growth = c(prevOutputs$growth, coefs[,"growth"]), growth = c(prevOutputs$growth, coefs[, "growth"]),
confidence = c(prevOutputs$confidence, coefs[,"confidence"]), confidence = c(prevOutputs$confidence, coefs[, "confidence"]),
layer = c(prevOutputs$layer, coefs[,"layer"]), layer = c(prevOutputs$layer, coefs[, "layer"]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
} }
@@ -272,86 +261,79 @@ getCode <- function(name, nodeDF) {
} }
getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) { getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
#utils::str(nodeDF)
#save(mapping, nodeDF, prevEdge, prefix, file="validEdges.RData")
edgeCols <- c("inputNode", "outputNode", "impact") edgeCols <- c("inputNode", "outputNode", "impact")
edgeM <- matrix(data = NA, nrow = 0, ncol = length(edgeCols), dimnames = list(NULL, edgeCols)) edgeM <- matrix(data = NA, nrow = 0, ncol = length(edgeCols), dimnames = list(NULL, edgeCols))
#to start let just get the statements and print them out.... # to start let just get the statements and print them out....
for (col in FIRST_NODE_COL:ncol(mapping)) { for (col in FIRST_NODE_COL:ncol(mapping)) {
count <- 0 count <- 0
for (row in 2:nrow(mapping)) { for (row in 2:nrow(mapping)) {
if (!is.na(mapping[row, col])) { if (!is.na(mapping[row, col])) {
edgeM <- rbind(edgeM, edgeM <- rbind(
c(getCode(mapping[row, 1], nodeDF), edgeM,
c(
getCode(mapping[row, 1], nodeDF),
getCode(colnames(mapping)[col], nodeDF), getCode(colnames(mapping)[col], nodeDF),
split(mapping[row,col])[match("impact", states)] split(mapping[row, col])[match("impact", states)]
) )
) )
count <- count + 1 count <- count + 1
} }
#if (count == 0) print(paste("No edges found for output", colnames(mapping)[col])) # if (count == 0) print(paste("No edges found for output", colnames(mapping)[col]))
} }
} }
if (is.null(prevEdge)) { if (is.null(prevEdge)) {
return (data.frame( return(data.frame(
input = edgeM[,"inputNode"], input = edgeM[, "inputNode"],
output = edgeM[,"outputNode"], output = edgeM[, "outputNode"],
impact = edgeM[,"impact"], impact = edgeM[, "impact"],
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
} else { } else {
return (data.frame( return(data.frame(
input = c(prevEdge$input, edgeM[,"inputNode"]), input = c(prevEdge$input, edgeM[, "inputNode"]),
output = c(prevEdge$output, edgeM[,"outputNode"]), output = c(prevEdge$output, edgeM[, "outputNode"]),
impact = c(prevEdge$impact, edgeM[,"impact"]), impact = c(prevEdge$impact, edgeM[, "impact"]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
} }
} }
parseMapping <- function(mapping, prevOutputs, prefix) { parseMapping <- function(mapping, prevOutputs, prefix) {
mapping <- mapping[,-1] mapping <- mapping[, -1]
mapping[,1] <- cleanTitles(mapping[,1]) mapping[, 1] <- cleanTitles(mapping[, 1])
nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix) nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix)
edgeDF <- getValidEdges(mapping, nodeDF, prevEdge = prevOutputs$edges, prefix) edgeDF <- getValidEdges(mapping, nodeDF, prevEdge = prevOutputs$edges, prefix)
#save(nodeDF, edgeDF, file="mapping.RData")
return(list( return(list(
#New structure # New structure
nodes = nodeDF, nodes = nodeDF,
edges = edgeDF edges = edgeDF
)) ))
} }
parseSheet <- function(fName) { parseSheet <- function(fName) {
#get sheet names
print(paste("starting sheet load", fName)) print(paste("starting sheet load", fName))
if (file.exists(fName)) { if (file.exists(fName)) {
names <- openxlsx::getSheetNames(fName) names <- openxlsx::getSheetNames(fName)
if (length(names) > 0) { if (length(names) > 0) {
sheets <- sort(delNA(match(names, mappings))) sheets <- sort(delNA(match(names, mappings)))
cat("starting sheet parse") cat("starting sheet parse")
#print(sheets) print(sheets)
if (sum(sheets == refs) == length(refs)) { if (sum(sheets == refs) == length(refs)) {
#read all mapping tables # read all mapping tables
scenario <- parseScenario(readXL(fName,mappings[1], startRow = 1), prefix = "p") scenario <- parseScenario(readXL(fName, mappings[1], startRow = 1), prefix = "p")
p_ba <- parseMapping(readXL(fName,mappings[2], startRow = 1), scenario, prefix = "ba") p_ba <- parseMapping(readXL(fName, mappings[2], startRow = 1), scenario, prefix = "ba")
p_op <- parseMapping(readXL(fName,mappings[3], startRow = 1), p_ba, prefix = "op") p_op <- parseMapping(readXL(fName, mappings[3], startRow = 1), p_ba, prefix = "op")
p_es <- parseMapping(readXL(fName,mappings[4], startRow = 1), p_op, prefix = "es") p_es <- parseMapping(readXL(fName, mappings[4], startRow = 1), p_op, prefix = "es")
legend <- readXL(fName,mappings[5], startRow = 1) legend <- readXL(fName, mappings[5], startRow = 1)
print("sheet load completed") print("sheet load completed")
return( return(
@@ -360,7 +342,6 @@ parseSheet <- function(fName) {
legend = legend legend = legend
) )
) )
} else { } else {
print(paste("Sheets found include", mappings[sheets])) print(paste("Sheets found include", mappings[sheets]))
cat("Missing sheets are:") cat("Missing sheets are:")

317
app.R
View File

@@ -8,7 +8,6 @@ modules::import(shinyBS)
modules::import(bnlearn) modules::import(bnlearn)
modules::import(visNetwork) modules::import(visNetwork)
modules::import(RColorBrewer) modules::import(RColorBrewer)
modules::import(plotly)
modules::import(openxlsx) modules::import(openxlsx)
modules::import(zip) modules::import(zip)
modules::import(DT) modules::import(DT)
@@ -16,7 +15,6 @@ modules::import(plyr)
modules::import(magrittr) modules::import(magrittr)
parser <- modules::use("Parses.R") parser <- modules::use("Parses.R")
rw <- modules::use("reWeight.R") rw <- modules::use("reWeight.R")
@@ -31,8 +29,8 @@ impLabels <- c("Very High", "High", "Medium", "Low", "Very Low")
ui <- dashboardPage( ui <- dashboardPage(
dashboardHeader(
dashboardHeader(title = "JNCC MESO online", title = "JNCC MESO online",
tags$li( tags$li(
id = "dropdownHelp", id = "dropdownHelp",
class = "dropdown", class = "dropdown",
@@ -80,15 +78,16 @@ ui <- dashboardPage(
) )
), ),
dashboardSidebar( dashboardSidebar(
sidebarMenu(id = "tabs", sidebarMenu(
id = "tabs",
menuItem("Introduction", tabName = "1", icon = icon("arrow-down")), menuItem("Introduction", tabName = "1", icon = icon("arrow-down")),
menuItem("Pressure Test", tabName = "2", icon = icon("arrow-down")), menuItem("Pressure Test", tabName = "2", icon = icon("arrow-down")),
menuItem("Bayesian Network", tabName = "3", icon = icon("atom")), menuItem("Bayesian Network", tabName = "3", icon = icon("atom")),
#menuItem("Habitats", tabName = "3", icon = icon("atlas")), # menuItem("Habitats", tabName = "3", icon = icon("atlas")),
#menuItem("Ingestion", tabName = "3", icon = icon("utensils")), # menuItem("Ingestion", tabName = "3", icon = icon("utensils")),
selectInput("modelSelect", "Select MESO model", choices = c(""), selected = NULL, multiple = FALSE), selectInput("modelSelect", "Select MESO model", choices = c(""), selected = NULL, multiple = FALSE),
#downloadButton("download", "", icon = icon("download")), # downloadButton("download", "", icon = icon("download")),
uiOutput("pressureList") uiOutput("pressureList")
) )
), ),
@@ -127,8 +126,10 @@ ui <- dashboardPage(
tags$p( tags$p(
style = "font-size: 12pt", style = "font-size: 12pt",
"Impact of pressures are as defined in ", "Impact of pressures are as defined in ",
tags$a(href = "https://www.marlin.ac.uk/sensitivity/sensitivity_rationale", tags$a(
"the Marine Evidence based Sensitivity Assessment (MarESA).", target = "_BLANK") href = "https://www.marlin.ac.uk/sensitivity/sensitivity_rationale",
"the Marine Evidence based Sensitivity Assessment (MarESA).", target = "_BLANK"
)
), ),
tags$p( tags$p(
style = "margin-top: 150px; font-size: 12pt", style = "margin-top: 150px; font-size: 12pt",
@@ -145,7 +146,8 @@ ui <- dashboardPage(
"Copyright Notice: All images, logos and sources are property and copyright of their respected owners" "Copyright Notice: All images, logos and sources are property and copyright of their respected owners"
) )
), ),
tabItem(tabName = "2", h2("Impact Distribution"), tabItem(
tabName = "2", h2("Impact Distribution"),
fluidRow( fluidRow(
column( column(
width = 6, width = 6,
@@ -169,13 +171,14 @@ ui <- dashboardPage(
p("Download results as Excel workbook") p("Download results as Excel workbook")
) )
), ),
plotlyOutput("layer1", height = "270px") %>% withSpinner(), plotly::plotlyOutput("layer1", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Processes"), h4("Effect on Ecosystem Processes"),
plotlyOutput("layer2", height = "270px") %>% withSpinner(), plotly::plotlyOutput("layer2", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Services"), h4("Effect on Ecosystem Services"),
plotlyOutput("layer3", height = "270px") %>% withSpinner() plotly::plotlyOutput("layer3", height = "270px") %>% withSpinner()
), ),
tabItem(tabName = "3",h2("Bayesian Network"), tabItem(
tabName = "3", h2("Bayesian Network"),
fluidPage( fluidPage(
p("Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!"), p("Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!"),
fluidRow( fluidRow(
@@ -216,7 +219,7 @@ ui <- dashboardPage(
) )
server <- function(input, output, session) { server <- function(input, output, session) {
#SERVER Constants # SERVER Constants
print("Loading data") print("Loading data")
@@ -224,7 +227,6 @@ server <- function(input, output, session) {
palette <- c("firebrick", "coral", "rosybrown", "tan", "salmon", "olivedrab", "seagreen", "aquamarine", "darkcyan", "dodgerblue", "steelblue", "royalblue") palette <- c("firebrick", "coral", "rosybrown", "tan", "salmon", "olivedrab", "seagreen", "aquamarine", "darkcyan", "dodgerblue", "steelblue", "royalblue")
models <- NULL models <- NULL
pressures <- NULL pressures <- NULL
@@ -254,7 +256,7 @@ server <- function(input, output, session) {
.selections <- reactiveValues( .selections <- reactiveValues(
model = 1, model = 1,
#runOnce = FALSE, # runOnce = FALSE,
bbnImpact = 1, bbnImpact = 1,
bbnNames = FALSE, bbnNames = FALSE,
bbnEdges = FALSE, bbnEdges = FALSE,
@@ -262,11 +264,21 @@ server <- function(input, output, session) {
) )
getImpact <- function(v) { getImpact <- function(v) {
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1]) if ((v == "INS") || (v == "IV")) {
if ((v == "HR") || (v == "III")) return(.resistanceScores[2]) return(.resistanceScores[1])
if ((v == "MR") || (v == "II")) return(.resistanceScores[3]) }
if ((v == "LR") || (v == "I")) return(.resistanceScores[4]) if ((v == "HR") || (v == "III")) {
if (v == "NR") return(.resistanceScores[5]) 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) as.numeric(v)
} }
@@ -274,10 +286,11 @@ server <- function(input, output, session) {
dplyr::select(hab, nodeType, Suggestion, node, newname) dplyr::select(hab, nodeType, Suggestion, node, newname)
newNameMap$hab <- stringr::str_replace_all(newNameMap$hab, "_", " ") newNameMap$hab <- stringr::str_replace_all(newNameMap$hab, "_", " ")
#save(newNameMap, file="nameMap.RData") # save(newNameMap, file="nameMap.RData")
stripStr <- function(nodeStr) { stripStr <- function(nodeStr) {
nodeStr %>% stringr::str_replace_all("\\.", "") %>% nodeStr %>%
stringr::str_replace_all("\\.", "") %>%
stringr::str_replace_all(" ", "") %>% stringr::str_replace_all(" ", "") %>%
stringr::str_replace_all("\\(", "") %>% stringr::str_replace_all("\\(", "") %>%
stringr::str_replace_all("\\)", "") %>% stringr::str_replace_all("\\)", "") %>%
@@ -286,24 +299,18 @@ server <- function(input, output, session) {
} }
setNewNames <- function(wb, habName) { setNewNames <- function(wb, habName) {
#habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
print(habName)
possNames <- newNameMap %>% possNames <- newNameMap %>%
dplyr::filter(hab==habName) %>% dplyr::filter(hab == habName) %>%
dplyr::mutate(node=stripStr(node)) dplyr::mutate(node = stripStr(node))
newNodes <- wb$p_es$nodes %>% dplyr::mutate(node=stripStr(name)) newNodes <- wb$p_es$nodes %>% dplyr::mutate(node = stripStr(name))
print(possNames$node)
print(newNodes$node)
newNames <- apply(newNodes, 1, function(row) { newNames <- apply(newNodes, 1, function(row) {
id <- match(row["node"], possNames$node) id <- match(row["node"], possNames$node)
print(paste(id, row["node"])) print(paste(id, row["node"]))
possNames$newname[id] possNames$newname[id]
}) })
print(newNames)
wb$p_es$nodes$name <- newNames wb$p_es$nodes$name <- newNames
return(wb) return(wb)
} }
@@ -318,15 +325,12 @@ server <- function(input, output, session) {
print(paste("attempting to load", paste0(dataStorage, fileList[idx]))) print(paste("attempting to load", paste0(dataStorage, fileList[idx])))
wb <- parser$parseSheet(paste0(dataStorage, fileList[idx])) wb <- parser$parseSheet(paste0(dataStorage, fileList[idx]))
#print(tmp)
wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact) wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact)
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("_", " ") stringr::str_replace_all("_", " ")
print(habName)
wb2 <- setNewNames(wb, habName) wb2 <- setNewNames(wb, habName)
@@ -334,27 +338,19 @@ server <- function(input, output, session) {
models <<- c(models, habName) models <<- c(models, habName)
print(paste("Model file successfully loaded", fileList[idx])) print(paste("Model file successfully loaded", fileList[idx]))
#save(tmp, file = "tmp.RData") cnt <- cnt + 1
cnt <- cnt+1
} }
} }
#save(modelList, file="models.RData")
updateSelectInput(session, "modelSelect", choices = models) updateSelectInput(session, "modelSelect", choices = models)
return(modelList) return(modelList)
} }
#parse on load sheets in the input sheet folder - replace with R Data # parse on load sheets in the input sheet folder - replace with R Data
modelList <- getAvailableModels() modelList <- getAvailableModels()
save(modelList, file="model.RData")
#print(load("modelList.RData"))
calcLikelihood <- function(layer, pressStatus, forPlotly) { calcLikelihood <- function(layer, pressStatus, forPlotly) {
isolate({ isolate({
modelList[[.selections$model]]$p_es$edges$values <<- sapply(modelList[[.selections$model]]$p_es$edges$impact, getImpact) modelList[[.selections$model]]$p_es$edges$values <<- sapply(modelList[[.selections$model]]$p_es$edges$impact, getImpact)
modelList[[.selections$model]]$p_es$nodes$growth <<- .resistanceScores["ssgr"] modelList[[.selections$model]]$p_es$nodes$growth <<- .resistanceScores["ssgr"]
modelList[[.selections$model]]$p_es$nodes$confidence <<- .resistanceScores["pressSD"] modelList[[.selections$model]]$p_es$nodes$confidence <<- .resistanceScores["pressSD"]
@@ -374,27 +370,17 @@ server <- function(input, output, session) {
expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ") expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ")
} }
expr <- substr(expr, 1, nchar(expr)-2) expr <- substr(expr, 1, nchar(expr) - 2)
expr <- paste0(expr, ")") expr <- paste0(expr, ")")
print(names(thisModel)) print(names(thisModel))
#Now do it in stages with one assessment per stage # Now do it in stages with one assessment per stage
thisModel$p_es$nodes$confidence <- 0.1 * thisModel$p_es$nodes$confidence thisModel$p_es$nodes$confidence <- 0.1 * thisModel$p_es$nodes$confidence
if (sum(pressStatus$status == "On") > 0) {
#save(pressStatus, thisModel, file="beforeWeight.RData")
if (sum(pressStatus$status=="On")>0) {
thisModel$p_es <- rw$reWeightModel(thisModel$p_es, pressStatus) thisModel$p_es <- rw$reWeightModel(thisModel$p_es, pressStatus)
} #else nothing to do } # 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"))) thisNet <- parser$buildGraph(thisModel$p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
@@ -408,17 +394,17 @@ server <- function(input, output, session) {
) )
}) })
#print(sampleDists) # print(sampleDists)
#displayCols <- match(nodeCodes, colnames(sampleDists)) # displayCols <- match(nodeCodes, colnames(sampleDists))
sampleDists <- round(sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits=2) sampleDists <- round(sampleDists[, match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits = 2)
means <- apply(sampleDists, 2, mean) means <- apply(sampleDists, 2, mean)
stdDev <- apply(sampleDists, 2, sd) stdDev <- apply(sampleDists, 2, sd)
#quantiles <- t(apply(sampleDists, 2, quantile, c(0.01, 0.25, 0.5, 0.75, 0.99))) # quantiles <- t(apply(sampleDists, 2, quantile, c(0.01, 0.25, 0.5, 0.75, 0.99)))
quantiles <- t(apply(sampleDists, 2, quantile, c(0.01, 0.25, 0.5, 0.75, 0.99))) 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))) print(paste("Building likelihoods from model, sample dists", length(thisModel$p_es$nodes$name), length(sampleDists)))
#str(quantiles) # str(quantiles)
if (forPlotly) { if (forPlotly) {
return(data.frame( return(data.frame(
@@ -426,19 +412,18 @@ server <- function(input, output, session) {
code = thisModel$p_es$nodes$code, code = thisModel$p_es$nodes$code,
layer = thisModel$p_es$nodes$layer, layer = thisModel$p_es$nodes$layer,
range = c( range = c(
#apply(sampleDists, 2, min), # apply(sampleDists, 2, min),
quantiles[,1], quantiles[, 1],
quantiles[,2], quantiles[, 2],
quantiles[,2], quantiles[, 2],
quantiles[,3], quantiles[, 3],
quantiles[,4], quantiles[, 4],
quantiles[,4], quantiles[, 4],
quantiles[,5] quantiles[, 5]
), ),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
} else { } else {
return(data.frame( return(data.frame(
name = thisModel$p_es$nodes$name, name = thisModel$p_es$nodes$name,
code = thisModel$p_es$nodes$code, code = thisModel$p_es$nodes$code,
@@ -449,14 +434,12 @@ server <- function(input, output, session) {
maxes = apply(sampleDists, 2, max), maxes = apply(sampleDists, 2, max),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
} }
} }
observeEvent(input$modelSelect, { observeEvent(input$modelSelect, {
.selections$model <<- match(input$modelSelect, models) .selections$model <<- match(input$modelSelect, models)
#.selections$runOnce <<- TRUE
}) })
observeEvent(reactiveValuesToList(input), { observeEvent(reactiveValuesToList(input), {
@@ -471,14 +454,13 @@ server <- function(input, output, session) {
newStatus <- data.frame(code = pressures$code, status = status, stringsAsFactors = FALSE) newStatus <- data.frame(code = pressures$code, status = status, stringsAsFactors = FALSE)
if (!identical(newStatus, .selections$pressStatus)) { #} || .selections$runOnce) { if (!identical(newStatus, .selections$pressStatus)) { # } || .selections$runOnce) {
#.selections$runOnce = FALSE # .selections$runOnce = FALSE
print("Running calc") print("Running calc")
.likelihoods$p_es <<- calcLikelihood(0, newStatus, TRUE) .likelihoods$p_es <<- calcLikelihood(0, newStatus, TRUE)
.selections$pressStatus <<- newStatus .selections$pressStatus <<- newStatus
} }
} }
}) })
@@ -487,27 +469,26 @@ server <- function(input, output, session) {
} }
output$pressureList <- renderUI({ output$pressureList <- renderUI({
#isolate({ # isolate({
if (!is.null(modelList[[.selections$model]]$p_es$nodes)) { if (!is.null(modelList[[.selections$model]]$p_es$nodes)) {
pressCodes <- which(startsWith(modelList[[.selections$model]]$p_es$nodes$code, "p")) pressCodes <- which(startsWith(modelList[[.selections$model]]$p_es$nodes$code, "p"))
#if (is.null(.selections$pressStatus)) status <- rep("Off", length(pressCodes)) else status <- .selections$pressStatus$status # if (is.null(.selections$pressStatus)) status <- rep("Off", length(pressCodes)) else status <- .selections$pressStatus$status
pressures <- data.frame( pressures <- data.frame(
code = modelList[[.selections$model]]$p_es$nodes$code[pressCodes], code = modelList[[.selections$model]]$p_es$nodes$code[pressCodes],
name = modelList[[.selections$model]]$p_es$nodes$name[pressCodes], name = modelList[[.selections$model]]$p_es$nodes$name[pressCodes],
#status = status, # status = status,
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
#This assumes all pressures are the same... # This assumes all pressures are the same...
setPressures(pressures) setPressures(pressures)
btnList <- apply(pressures, 1, makeRadioButtons) btnList <- apply(pressures, 1, makeRadioButtons)
} }
}) })
observeEvent(input$bbnImpactSelect, { observeEvent(input$bbnImpactSelect, {
#filter nodes and edges to # filter nodes and edges to
.selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)] .selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)]
}) })
@@ -517,20 +498,20 @@ server <- function(input, output, session) {
observeEvent(input$bbnDisplayEdges, { observeEvent(input$bbnDisplayEdges, {
.selections$bbnEdges <- input$bbnDisplayEdges .selections$bbnEdges <- input$bbnDisplayEdges
}) })
observeEvent(input$layer1Slider, { observeEvent(input$layer1Slider, {
showModal( showModal(
modalDialog({ modalDialog(
{
tagList( tagList(
sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step = 0.01), 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("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("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("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("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step = 0.01),
sliderInput("ssgr", "Zero intercept", -0.1, 0.1,.resistanceScores[6], step = 0.01), sliderInput("ssgr", "Zero intercept", -0.1, 0.1, .resistanceScores[6], step = 0.01),
sliderInput("l1PressSD", "Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01) sliderInput("l1PressSD", "Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01)
) )
}, },
@@ -539,13 +520,12 @@ server <- function(input, output, session) {
modalButton("Cancel"), modalButton("Cancel"),
actionButton("modalOK", "OK") actionButton("modalOK", "OK")
), ),
size = "s") size = "s"
)
) )
}) })
observeEvent(input$modalOK, { observeEvent(input$modalOK, {
.resistanceScores["nr"] <<- -input$l1VH .resistanceScores["nr"] <<- -input$l1VH
.resistanceScores["lr"] <<- -input$l1H .resistanceScores["lr"] <<- -input$l1H
.resistanceScores["mr"] <<- -input$l1M .resistanceScores["mr"] <<- -input$l1M
@@ -557,7 +537,6 @@ server <- function(input, output, session) {
.likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus, TRUE) .likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus, TRUE)
removeModal() removeModal()
}) })
@@ -622,35 +601,30 @@ server <- function(input, output, session) {
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
edges <- edges[(abs(edges$values) >= .selections$bbnImpact),] edges <- edges[(abs(edges$values) >= .selections$bbnImpact), ]
nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c("On")]),] 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) { if (nrow(nodeNet) > 0) {
#do pressures # do pressures
edgeNet <- edges[edges$from %in% nodeNet$id, ] edgeNet <- edges[edges$from %in% nodeNet$id, ]
idx <- 1 idx <- 1
repeat { repeat {
nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ] nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ]
nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),] nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id), ]
edgesToAdd <- edges[edges$from %in% nodesToAdd$id, ] edgesToAdd <- edges[edges$from %in% nodesToAdd$id, ]
edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id),] edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id), ]
idx <- idx + 1 idx <- idx + 1
if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break
nodeNet <- rbind(nodeNet, nodesToAdd) nodeNet <- rbind(nodeNet, nodesToAdd)
edgeNet <- rbind(edgeNet, edgesToAdd) edgeNet <- rbind(edgeNet, edgesToAdd)
} # until finished
} #until finished
} else { } else {
edgeNet <- edges edgeNet <- edges
} }
print(paste(nrow(model$legend), length(palette)))
legendDF <- data.frame( legendDF <- data.frame(
id = 1:nrow(model$legend), id = 1:nrow(model$legend),
label = model$legend, label = model$legend,
@@ -662,81 +636,72 @@ server <- function(input, output, session) {
visExport() %>% visExport() %>%
visLegend(useGroups = FALSE, addNodes = legendDF) %>% visLegend(useGroups = FALSE, addNodes = legendDF) %>%
visHierarchicalLayout(nodeSpacing = nodeSpacing, direction = "LR") %>% visHierarchicalLayout(nodeSpacing = nodeSpacing, direction = "LR") %>%
visOptions(highlightNearest = TRUE) #%>% visOptions(highlightNearest = TRUE) # %>%
#visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE) # visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
} }
output$bbnGraphPlot <- renderVisNetwork({ output$bbnGraphPlot <- renderVisNetwork({
makeBbnGraph(modelList[[.selections$model]]) makeBbnGraph(modelList[[.selections$model]])
}) })
#observe({
# visNetworkProxy("bbnGraphPlot") %>%
# visStabilize(iterations = 10)
#})
getModelName <- function() { getModelName <- function() {
paste0("data/", input$modelSelect, ".xlsx") paste0("data/", input$modelSelect, ".xlsx")
} }
genPlot <- function(boxPlot, title, paletteLength) { genPlot <- function(boxPlot, title, paletteLength) {
if (nrow(boxPlot) > 0) { if (nrow(boxPlot) > 0) {
#print(paste('Palette length', paletteLength))
#palette <- brewer.pal(paletteLength, "Set3")
#palette <- c("red", "sienna3", "plum2", "rosybrown4", "sandybrown", "yellow", "seashell3", "palegreen", "springgreen4", "steelblue", "azure")
names(palette) <- 1:length(palette) names(palette) <- 1:length(palette)
#print(paste("Box plot, colours", nrow(boxPlot), length(colours))) xform <- list(
#cat(colours) categoryorder = "array",
xform <- list(categoryorder = "array", categoryarray = boxPlot[, 1],
categoryarray = boxPlot[,1], zerolinewidth = 10
zerolinewidth = 10) )
#
plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
layout(xaxis = xform, yaxis=list(dtick=0.25, range=c(-1.25, 1.25)), showlegend = FALSE, title = title)
plotly::plot_ly(boxPlot, x = boxPlot[, 1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
plotly::layout(xaxis = xform, yaxis = list(dtick = 0.25, range = c(-1.25, 1.25)), showlegend = FALSE, title = title)
} }
} }
prepPlot <- function(code = "ba", name = "Functional Group") { 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)]
colnames(thisPlot) <- c(name, "Group", "Range") colnames(thisPlot) <- c(name, "Group", "Range")
title <- paste(input$modelSelect, name, "Box Plot") title <- paste(input$modelSelect, name, "Box Plot")
paletteLength <- nrow(modelList[[.selections$model]]$legend) paletteLength <- nrow(modelList[[.selections$model]]$legend)
#print(paste('prep plot palette', paletteLength)) # print(paste('prep plot palette', paletteLength))
genPlot(thisPlot, title, paletteLength) genPlot(thisPlot, title, paletteLength)
} }
} }
output$layer1 <- renderPlotly({ output$layer1 <- plotly::renderPlotly({
prepPlot("ba", "Functional Groups") prepPlot("ba", "Functional Groups")
}) })
output$layer2 <- renderPlotly({ output$layer2 <- plotly::renderPlotly({
prepPlot("op", "Ecosystem Processes") prepPlot("op", "Ecosystem Processes")
}) })
output$layer3 <- renderPlotly({ output$layer3 <- plotly::renderPlotly({
prepPlot("es", "Ecosystem Services") prepPlot("es", "Ecosystem Services")
}) })
isAbsolutePath = function( path ){ isAbsolutePath <- function(path) {
if( path == "~" ) if (path == "~") {
return(TRUE); return(TRUE)
if( grepl("^~/", path) ) }
return(TRUE); if (grepl("^~/", path)) {
if( grepl("^.:(/|\\\\)", path) ) return(TRUE)
return(TRUE); }
if( grepl("^(/|\\\\)", path) ) if (grepl("^.:(/|\\\\)", path)) {
return(TRUE); return(TRUE)
return(FALSE); }
if (grepl("^(/|\\\\)", path)) {
return(TRUE)
}
return(FALSE)
} }
output$linkBackgroundData <- downloadHandler( output$linkBackgroundData <- downloadHandler(
@@ -748,66 +713,68 @@ server <- function(input, output, session) {
) )
makeLikelihoods <- function() { makeLikelihoods <- function() {
likeliTab <- as.data.frame( likeliTab <- as.data.frame(
cbind( cbind(
.likelihoods$p_es, codeVal = sapply( .likelihoods$p_es,
codeVal = sapply(
.likelihoods$p_es$code, function(str) { .likelihoods$p_es$code, function(str) {
if (startsWith(str, 'p')) as.numeric(substring(str, 2, nchar(str))) if (startsWith(str, "p")) {
else as.numeric(substring(str, 3, nchar(str))) as.numeric(substring(str, 2, nchar(str)))
} else {
as.numeric(substring(str, 3, nchar(str)))
} }
)), }
stringsAsFactors=FALSE )
),
stringsAsFactors = FALSE
) )
likeliTab <- arrange(likeliTab, layer, codeVal) likeliTab <- arrange(likeliTab, layer, codeVal)
outputRows <- trunc(nrow(likeliTab)/7) outputRows <- trunc(nrow(likeliTab) / 7)
outputTab <- NULL outputTab <- NULL
for (idx in 1:outputRows) { for (idx in 1:outputRows) {
elementRow <- (idx - 1) * 7 + 1 elementRow <- (idx - 1) * 7 + 1
tabRow <-c( tabRow <- c(
name = likeliTab$name[elementRow], name = likeliTab$name[elementRow],
code = likeliTab$code[elementRow], code = likeliTab$code[elementRow],
layer = likeliTab$layer[elementRow], layer = likeliTab$layer[elementRow],
min=likeliTab$range[elementRow], min = likeliTab$range[elementRow],
q1 =likeliTab$range[elementRow+2], q1 = likeliTab$range[elementRow + 2],
median =likeliTab$range[elementRow+3], median = likeliTab$range[elementRow + 3],
q3 =likeliTab$range[elementRow+4], q3 = likeliTab$range[elementRow + 4],
max =likeliTab$range[elementRow+6] max = likeliTab$range[elementRow + 6]
) )
outputTab <- rbind(outputTab, tabRow) outputTab <- rbind(outputTab, tabRow)
} }
likelihoods <- data.frame( likelihoods <- data.frame(
name = outputTab[,1], name = outputTab[, 1],
code = outputTab[,2], code = outputTab[, 2],
layer = as.numeric(outputTab[,3]), layer = as.numeric(outputTab[, 3]),
max =as.numeric(outputTab[,8]), max = as.numeric(outputTab[, 8]),
q3 =as.numeric(outputTab[,7]), q3 = as.numeric(outputTab[, 7]),
median =as.numeric(outputTab[,6]), median = as.numeric(outputTab[, 6]),
q1 =as.numeric(outputTab[,5]), q1 = as.numeric(outputTab[, 5]),
min=as.numeric(outputTab[,4]), min = as.numeric(outputTab[, 4]),
stringsAsFactors = FALSE, stringsAsFactors = FALSE,
row.names = NULL row.names = NULL
) )
} }
output$download <- downloadHandler( output$download <- downloadHandler(
filename = function() {
filename = function() { paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx") }, paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx")
},
content = function(file) { content = function(file) {
showModal( showModal(
modalDialog( modalDialog(
fluidRow( fluidRow(
column(width = 12) %>% withSpinner(type = 5, proxy.height = "200px") column(width = 12) %>% withSpinner(type = 5, proxy.height = "200px")
), ),
footer=div() footer = div()
) )
) )
@@ -817,8 +784,6 @@ server <- function(input, output, session) {
dir.create(tmp) dir.create(tmp)
setwd(tmp) setwd(tmp)
l <- list( l <- list(
pressures = .selections$pressStatus, pressures = .selections$pressStatus,
nodes = modelList[[.selections$model]]$p_es$nodes, nodes = modelList[[.selections$model]]$p_es$nodes,
@@ -828,12 +793,8 @@ server <- function(input, output, session) {
) )
xl <- write.xlsx(l, "dataset.xlsx") xl <- write.xlsx(l, "dataset.xlsx")
#zipFile <- zipr(file, c("dataset.xlsx"))
file.copy("dataset.xlsx", file) file.copy("dataset.xlsx", file)
#print(paste("zip file complete", zipFile))
setwd(oldDir) setwd(oldDir)
unlink(tmp) unlink(tmp)
@@ -841,8 +802,6 @@ server <- function(input, output, session) {
}, },
contentType = "application/xlsx" contentType = "application/xlsx"
) )
} }
shinyApp(ui, server) shinyApp(ui, server)

96
extract.R
View File

@@ -1,16 +1,21 @@
#R script to upload the existing spreadsheets and homologise them # R script to upload the existing spreadsheets and homologise them
library(magrittr) modules::import(magrittr)
fList <- list.files("data", pattern="*.xlsx")
#Objective to create data tables with fList <- list.files("data", pattern = "*.xlsx")
# Objective to create data tables with
linkCheck <- function(nodeType, nodeString, nodeStringCheck) { linkCheck <- function(nodeType, nodeString, nodeStringCheck) {
nodeString <- stringr::str_replace_all(nodeString, "\\.", " ") nodeString <- stringr::str_replace_all(nodeString, "\\.", " ")
res <- sapply(nodeString, match, nodeStringCheck$Nodes) %>% is.na() %>% which() res <- sapply(nodeString, match, nodeStringCheck$Nodes) %>%
if (length(res)>0) print(paste("Clean up error found in", nodeType, "mapping at", names(res))) is.na() %>%
which()
if (length(res) > 0) print(paste("Clean up error found in", nodeType, "mapping at", names(res)))
} }
getNodeVals <- function(nodeStr) { getNodeVals <- function(nodeStr) {
params <- stringr::str_split(nodeStr, ",") %>% unlist() %>% trimws() params <- stringr::str_split(nodeStr, ",") %>%
unlist() %>%
trimws()
paramVals <- stringr::str_split(params, "=") paramVals <- stringr::str_split(params, "=")
vals <- c() vals <- c()
lapply(paramVals, function(l) { lapply(paramVals, function(l) {
@@ -21,18 +26,20 @@ getNodeVals <- function(nodeStr) {
vals vals
} }
#We want to build a node table and an impact table. # We want to build a node table and an impact table.
#Colnames of the node table will be # Colnames of the node table will be
#Hab, Node Type, Node, Node Layer, Growth, .... # Hab, Node Type, Node, Node Layer, Growth, ....
#The edges table will be # The edges table will be
#Hab, In Node, Out Node, Params, .... # Hab, In Node, Out Node, Params, ....
sheetNames <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend") sheetNames <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend")
cleanNames <- function(namVec) { cleanNames <- function(namVec) {
stringr::str_replace_all(namVec, "\\.", " ") %>% trimws() %>% tolower() stringr::str_replace_all(namVec, "\\.", " ") %>%
trimws() %>%
tolower()
} }
nodeTable <- tibble::tibble() nodeTable <- tibble::tibble()
@@ -40,43 +47,45 @@ nodeTable <- tibble::tibble()
for (wbIdx in 1:length(fList)) { for (wbIdx in 1:length(fList)) {
wb <- openxlsx::loadWorkbook(paste0("data/", fList[wbIdx])) wb <- openxlsx::loadWorkbook(paste0("data/", fList[wbIdx]))
hab <- stringr::str_split(fList[wbIdx], "\\.")[[1]][1] hab <- stringr::str_split(fList[wbIdx], "\\.")[[1]][1]
#get pressure names
#Drop the time column no use at all....
sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[1])[ ,-1] # Drop the time column no use at all....
sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[1])[, -1]
pressures <- cleanNames(colnames(sheet)) pressures <- cleanNames(colnames(sheet))
pressure_nodes <- sheet[1,] pressure_nodes <- sheet[1, ]
sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[2])[ ,-1] sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[2])[, -1]
pressure_check <- na.omit(sheet[,1:2]) pressure_check <- na.omit(sheet[, 1:2])
sheet2 <- na.omit(sheet[, -c(1,2)]) sheet2 <- na.omit(sheet[, -c(1, 2)])
ba <- cleanNames(colnames(sheet2)) ba <- cleanNames(colnames(sheet2))
ba_nodes <- sheet2[1,] ba_nodes <- sheet2[1, ]
pressImpact <- sheet2[-1,] pressImpact <- sheet2[-1, ]
#linkCheck("pressures", pressures, pressure_check) # linkCheck("pressures", pressures, pressure_check)
sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[3])[ ,-1] sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[3])[, -1]
ba_check <- na.omit(sheet[,1:2]) ba_check <- na.omit(sheet[, 1:2])
sheet2 <- na.omit(sheet[, -c(1,2)]) sheet2 <- na.omit(sheet[, -c(1, 2)])
op <- cleanNames(colnames(sheet2)) op <- cleanNames(colnames(sheet2))
op_nodes <- sheet2[1,] op_nodes <- sheet2[1, ]
baImpact <- sheet2[-1,] baImpact <- sheet2[-1, ]
#linkCheck("bioassemblages", ba, ba_check) # linkCheck("bioassemblages", ba, ba_check)
sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[4])[ ,-1]
op_check <- na.omit(sheet[,1:2]) sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[4])[, -1]
sheet2 <- na.omit(sheet[, -c(1,2)]) op_check <- na.omit(sheet[, 1:2])
sheet2 <- na.omit(sheet[, -c(1, 2)])
es <- cleanNames(colnames(sheet2)) es <- cleanNames(colnames(sheet2))
es_nodes <- sheet2[1,] es_nodes <- sheet2[1, ]
opImpact <- sheet2[-1,] opImpact <- sheet2[-1, ]
#linkCheck("outputprocesses", op, op_check) # linkCheck("outputprocesses", op, op_check)
legend <- openxlsx::readWorkbook(wb, sheet=sheetNames[5])
legend <- openxlsx::readWorkbook(wb, sheet = sheetNames[5])
nodeType <- c( nodeType <- c(
rep("pressure", length(pressures)), rep("pressure", length(pressures)),
@@ -85,27 +94,20 @@ for (wbIdx in 1:length(fList)) {
rep("ecosystemservice", length(es)) rep("ecosystemservice", length(es))
) )
res <- t(sapply(es_nodes[1, ], getNodeVals)) %>% as.data.frame()
res <- t(sapply(es_nodes[1,], getNodeVals)) %>% as.data.frame()
names(res) <- cleanNames(names(res)) names(res) <- cleanNames(names(res))
res <- res %>% mutate(nodeName=names(res)) res <- res %>% mutate(nodeName = names(res))
nodeTable <- nodeTable %>% dplyr::bind_rows( nodeTable <- nodeTable %>% dplyr::bind_rows(
tibble::tibble( tibble::tibble(
hab=hab, hab = hab,
nodeType=nodeType, nodeType = nodeType,
res res
) )
) )
} }
mapNewNames <- function() { mapNewNames <- function() {
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)
save(newNameMap, file="nameMap.RData")
} }

117
reWeight.R
View File

@@ -1,123 +1,116 @@
modules::import(magrittr) modules::import(magrittr)
reWeightLayer <- function(nestedLayerTib, fudge=1) { reWeightLayer <- function(nestedLayerTib, fudge = 1) {
for (idx in 1:nrow(nestedLayerTib)) { for (idx in 1:nrow(nestedLayerTib)) {
#print(nestedLayerTib$data[idx])
thisData <- nestedLayerTib$data[idx][[1]] thisData <- nestedLayerTib$data[idx][[1]]
#Calculate the overall depletion rate # Calculate the overall depletion rate
#depRate <- ifelse(thisData$values<0, -thisData$values, 0) # depRate <- ifelse(thisData$values<0, -thisData$values, 0)
#Re-adjust those weightings in line with the number applied # Re-adjust those weightings in line with the number applied
survived <- 1 survived <- 1
grown <- 1 grown <- 1
for (depIdx in 1:nrow(thisData)) { for (depIdx in 1:nrow(thisData)) {
if (thisData$values[depIdx]<0) survived <- survived * (1 + thisData$values[depIdx]) else if (thisData$values[depIdx] < 0) {
grown <- (1-thisData$values[depIdx]) * grown survived <- survived * (1 + thisData$values[depIdx])
} else {
grown <- (1 - thisData$values[depIdx]) * grown
} }
#Update the edge weightings to reflect the combined depletion on the BA from each of the edges }
# Update the edge weightings to reflect the combined depletion on the BA from each of the edges
effDepRate <- survived - 1 effDepRate <- survived - 1
effGrowthRate <- 1-grown effGrowthRate <- 1 - grown
#print(effDepRate)
if (sum(thisData$values)==0) newValues <- rep(0, length(thisData$values)) else if (sum(thisData$values) == 0) {
newValues <- round(thisData$values/sum(thisData$values)*(effDepRate+effGrowthRate), digits=3) newValues <- rep(0, length(thisData$values))
#print(paste(idx, paste(newValues, collapse=","))) } else {
newValues <- round(thisData$values / sum(thisData$values) * (effDepRate + effGrowthRate), digits = 3)
}
nestedLayerTib$data[idx][[1]]$values <- newValues / fudge nestedLayerTib$data[idx][[1]]$values <- newValues / fudge
} }
return(nestedLayerTib %>% tidyr::unnest(cols=c(data))) return(nestedLayerTib %>% tidyr::unnest(cols = c(data)))
} }
assignWeights <- function( assignWeights <- function(edgesTib, incode, outcode, value) {
edgesTib,
incode,
outcode,
value) {
for (idx in 1:length(incode)) { for (idx in 1:length(incode)) {
ref <- intersect(which(edgesTib$input == incode[idx]), ref <- intersect(
which(edgesTib$output == outcode[idx])) which(edgesTib$input == incode[idx]),
which(edgesTib$output == outcode[idx])
)
utils::str(ref) if (length(ref) > 1) stop("Error has occurred with multiple edges between two nodes")
if (length(ref)>1) stop("Error has occurred with multiple edges between two nodes")
print(paste(ref, edgesTib$values[ref], value[idx]))
edgesTib$values[ref] <- value[idx] edgesTib$values[ref] <- value[idx]
#Set the appropriate values
} }
return(edgesTib) return(edgesTib)
} }
reWeightModel <- function(thisNet, pressStatus) { reWeightModel <- function(thisNet, pressStatus) {
print("About to recalc p - ba") print("About to recalc p - ba")
#what is the depletion factor for each of the pressures applied to the BA? # what is the depletion factor for each of the pressures applied to the BA?
p_on <- pressStatus %>% p_on <- pressStatus %>%
dplyr::filter(status=="On") %>% dplyr::filter(status == "On") %>%
dplyr::left_join(thisNet$nodes, by=c("code"="code")) %>% dplyr::left_join(thisNet$nodes, by = c("code" = "code")) %>%
dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% dplyr::left_join(thisNet$edges, by = c("code" = "input")) %>%
dplyr::mutate(values=values * 0.9) dplyr::mutate(values = values * 0.9)
print("before")
print(sum(p_on$values))
p_on <- p_on %>% p_on <- p_on %>%
dplyr::rename(presscode=code) %>% dplyr::rename(presscode = code) %>%
dplyr::rename(ba_code=output) %>% dplyr::rename(ba_code = output) %>%
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 = 1)
print("About to recalc ba - op") print("About to recalc ba - op")
#Repeat for the linkage between ba and op # Repeat for the linkage between ba and op
bas <- unique(newP$ba_code) bas <- unique(newP$ba_code)
ba_impacted <- thisNet$nodes %>% ba_impacted <- thisNet$nodes %>%
dplyr::filter(code %in% bas) %>% dplyr::filter(code %in% bas) %>%
dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% dplyr::left_join(thisNet$edges, by = c("code" = "input")) %>%
tidyr::drop_na() %>% tidyr::drop_na() %>%
dplyr::rename(ba_code=code) %>% dplyr::rename(ba_code = code) %>%
dplyr::select(layer, output, ba_code, values) %>% dplyr::select(layer, output, ba_code, values) %>%
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=4)
print("About to recalc op - es") print("About to recalc op - es")
#Repeat for the linkage between op and es # Repeat for the linkage between op and es
ops <- unique(newBA$op_code) ops <- unique(newBA$op_code)
op_impacted <- thisNet$nodes %>% op_impacted <- thisNet$nodes %>%
dplyr::filter(code %in% ops) %>% dplyr::filter(code %in% ops) %>%
dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% dplyr::left_join(thisNet$edges, by = c("code" = "input")) %>%
dplyr::rename(op_code=code) %>% dplyr::rename(op_code = code) %>%
tidyr::drop_na() %>% tidyr::drop_na() %>%
dplyr::select(layer, output, op_code, values) %>% dplyr::select(layer, output, op_code, values) %>%
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=2) 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")
ess <- unique(newOP$es_code) ess <- unique(newOP$es_code)
es_impacted <- thisNet$nodes %>% es_impacted <- thisNet$nodes %>%
dplyr::filter(code %in% ess) %>% dplyr::filter(code %in% ess) %>%
dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% dplyr::left_join(thisNet$edges, by = c("code" = "input")) %>%
dplyr::rename(es_code=code) %>% dplyr::rename(es_code = code) %>%
tidyr::drop_na() %>% tidyr::drop_na() %>%
dplyr::select(layer, output, es_code, values) %>% dplyr::select(layer, output, es_code, values) %>%
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=4) newES <- reWeightLayer(es_impacted, fudge = 4)
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)
@@ -125,8 +118,8 @@ reWeightModel <- function(thisNet, pressStatus) {
thisNet$edges <- assignWeights(thisNet$edges, incode, outcode, value) thisNet$edges <- assignWeights(thisNet$edges, incode, outcode, value)
print("exitting reweighting process") print("exitting reweighting process")
return(thisNet) return(thisNet)
} }