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

StyleR run

Browse Source
This commit is contained in:
Craig Williams
2022-04-07 09:24:38 +01:00
parent be5319a423
commit 882f4cfb69
4 changed files with 507 additions and 492 deletions
Download Patch File Download Diff File Expand all files Collapse all files

142
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)) {
@@ -58,7 +58,7 @@ parseScenario <- function(press, prefix = "p") {
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) {
@@ -71,9 +71,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,19 +85,18 @@ 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))
for (n in 1:length(params)) { for (n in 1:length(params)) {
kvp <- unlist(strsplit(params[n], "=")) kvp <- unlist(strsplit(params[n], "="))
ref <- match(getInitial(trimws(kvp[1])), getInitial(states)) ref <- match(getInitial(trimws(kvp[1])), getInitial(states))
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]))
} }
} }
return(values) return(values)
@@ -119,18 +118,18 @@ 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,24 +140,24 @@ 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) # 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") save(modelDefn, file = "buildGraph.RData")
#print("about to build network") # print("about to build network")
#print(paste0(inputText, edges)) # print(paste0(inputText, edges))
@@ -176,15 +175,15 @@ 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) # print(allDists)
cfit <- custom.fit(net, allDists) cfit <- custom.fit(net, allDists)
cat("about to calculate sample distributions") cat("about to calculate sample distributions")
#print(outNodes) # 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) # stdDev <- sd(sampleDists)
print("sample distribution build successful") print("sample distribution build successful")
@@ -206,11 +205,11 @@ buildGraph <- function(model, desc) {
getValidNodes <- function(mapping, prevOutputs, prefix) { getValidNodes <- function(mapping, prevOutputs, prefix) {
#Find row id for input nodes, internal and published # Find row id for input nodes, internal and published
inputNodes <- mapping[2:nrow(mapping),1] inputNodes <- mapping[2:nrow(mapping), 1]
#check that all input nodes are in the previous table # check that all input nodes are in the previous table
inputNodes <- delNA(mapping[mapping[,"Node.Type"] == "input", "Nodes"]) 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 +220,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 +229,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 +241,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 +253,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,66 +271,67 @@ getCode <- function(name, nodeDF) {
} }
getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) { getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
#utils::str(nodeDF) # utils::str(nodeDF)
#save(mapping, nodeDF, prevEdge, prefix, file="validEdges.RData") # 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") # 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 # get sheet names
print(paste("starting sheet load", fName)) print(paste("starting sheet load", fName))
@@ -339,19 +339,18 @@ parseSheet <- function(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 +359,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:")

646
app.R
View File

@@ -31,198 +31,203 @@ 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",
tags$head( tags$head(
tags$script( tags$script(
paste0( paste0(
"$(document).ready(function(){", "$(document).ready(function(){",
" $('#dropdownHelp')", " $('#dropdownHelp')",
" .find('ul')", " .find('ul')",
" .click(function(e) { e.stopPropagation(); });", " .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( tags$a(
sidebarMenu(id = "tabs", href = "javascript:void(0);",
menuItem("Introduction", tabName = "1", icon = icon("arrow-down")), class = "dropdown-toggle",
menuItem("Pressure Test", tabName = "2", icon = icon("arrow-down")), `data-toggle` = "dropdown",
menuItem("Bayesian Network", tabName = "3", icon = icon("atom")), icon("question")
#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")
)
), ),
dashboardBody( tags$ul(
tabItems( class = "dropdown-menu",
tabItem( style = "left: auto; right: 0; min-width: 200px",
tabName = "1", h2("Introduction"), tags$li(
tags$p( tags$div(
style = "font-size: 12pt", style = "margin-left: auto; margin-right: auto; width: 90%;",
"This website is provided for the Joint Nature Conservation Committee (JNCC) and is provided by", tags$a(
tags$a(href = "https://avsdev.uk", "AVS Developments", target = "_BLANK"), href = "Manual.pdf",
", working under contract to ", target = "_BLANK",
tags$a(href = "https://www.mba.ac.uk", "the Marine Biology Association.", target = "_BLANK") "Open user guide in tab"
),
tags$p(
style = "font-size: 12pt",
"This website provides a Proof of Concept visualisation tool to assist in understanding the probabilitic impact that
Anthropogenic Pressures (i.e. human activities) has on the habitats of sub-littoral areas of the United Kingdom."
),
tags$p(
style = "font-size: 12pt",
"The tool provides a mapping using a Continuous Gaussian Bayesian Belief Network from the
Anthropogenic Pressures through the biotopes and to the Ecosystem processes and ultimately the
Ecosystem services, to which the habitat supports."
),
tags$p(
style = "font-size: 12pt",
"By selecting combinations of pressures on the left hand side bar, the impact on biotopes and functions of the
habitat can be estimated on the graphs shown on the Pressure test page.
The Bayesian Network page shows the structure of the Bayesian Network itself. "
),
tags$p(
style = "font-size: 12pt",
"Five substrate types have been modelled (coarse sediment, mixed sediment, mud, rock and sand)."
),
tags$p(
style = "font-size: 12pt",
"Impact of pressures are as defined in ",
tags$a(href = "https://www.marlin.ac.uk/sensitivity/sensitivity_rationale",
"the Marine Evidence based Sensitivity Assessment (MarESA).", target = "_BLANK")
),
tags$p(
style = "margin-top: 150px; font-size: 12pt",
"Further information on the rationalale and supporting information can be found in the Studiy's Final Report
available as a download from the Help pages selectable from the Question Mark logo on the
top right hand side of the website."
),
tags$p(
style = "margin-top: 150px; font-size: 10pt",
"GDPR Notice: This website only uses cookies to provide core functionality. No personal data cookies are used."
),
tags$p(
style = "font-size: 10pt",
"Copyright Notice: All images, logos and sources are property and copyright of their respected owners"
) )
), )
tabItem(tabName = "2", h2("Impact Distribution"), ),
fluidRow( tags$li(
column( tags$div(
width = 6, style = "margin-left: auto; margin-right: auto; width: 90%;",
h4("Effect on Functional Groups") tags$a(
), href = "Report.pdf",
column( target = "_BLANK",
width = 1, "Open Final Report in tab"
actionButton("layer1Slider", "1", icon = icon("sliders-h"))
),
column(
width = 2,
p("Custom sense weighting")
),
column(
width = 1,
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,
p("Download results as Excel workbook")
)
),
plotlyOutput("layer1", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Processes"),
plotlyOutput("layer2", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Services"),
plotlyOutput("layer3", height = "270px") %>% withSpinner()
),
tabItem(tabName = "3",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),
shinyBS::bsTooltip("bbnDisplayNames", "Four MESO models have been defined thus far")
),
column(
width = 4,
checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE),
shinyBS::bsTooltip("bbnDisplayEdges", "Edges are removed")
),
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")
)
)
) )
) )
) )
) )
)
),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("Introduction", tabName = "1", icon = icon("arrow-down")),
menuItem("Pressure Test", tabName = "2", icon = icon("arrow-down")),
menuItem("Bayesian Network", tabName = "3", 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")
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "1", h2("Introduction"),
tags$p(
style = "font-size: 12pt",
"This website is provided for the Joint Nature Conservation Committee (JNCC) and is provided by",
tags$a(href = "https://avsdev.uk", "AVS Developments", target = "_BLANK"),
", working under contract to ",
tags$a(href = "https://www.mba.ac.uk", "the Marine Biology Association.", target = "_BLANK")
),
tags$p(
style = "font-size: 12pt",
"This website provides a Proof of Concept visualisation tool to assist in understanding the probabilitic impact that
Anthropogenic Pressures (i.e. human activities) has on the habitats of sub-littoral areas of the United Kingdom."
),
tags$p(
style = "font-size: 12pt",
"The tool provides a mapping using a Continuous Gaussian Bayesian Belief Network from the
Anthropogenic Pressures through the biotopes and to the Ecosystem processes and ultimately the
Ecosystem services, to which the habitat supports."
),
tags$p(
style = "font-size: 12pt",
"By selecting combinations of pressures on the left hand side bar, the impact on biotopes and functions of the
habitat can be estimated on the graphs shown on the Pressure test page.
The Bayesian Network page shows the structure of the Bayesian Network itself. "
),
tags$p(
style = "font-size: 12pt",
"Five substrate types have been modelled (coarse sediment, mixed sediment, mud, rock and sand)."
),
tags$p(
style = "font-size: 12pt",
"Impact of pressures are as defined in ",
tags$a(
href = "https://www.marlin.ac.uk/sensitivity/sensitivity_rationale",
"the Marine Evidence based Sensitivity Assessment (MarESA).", target = "_BLANK"
)
),
tags$p(
style = "margin-top: 150px; font-size: 12pt",
"Further information on the rationalale and supporting information can be found in the Studiy's Final Report
available as a download from the Help pages selectable from the Question Mark logo on the
top right hand side of the website."
),
tags$p(
style = "margin-top: 150px; font-size: 10pt",
"GDPR Notice: This website only uses cookies to provide core functionality. No personal data cookies are used."
),
tags$p(
style = "font-size: 10pt",
"Copyright Notice: All images, logos and sources are property and copyright of their respected owners"
)
),
tabItem(
tabName = "2", h2("Impact Distribution"),
fluidRow(
column(
width = 6,
h4("Effect on Functional Groups")
),
column(
width = 1,
actionButton("layer1Slider", "1", icon = icon("sliders-h"))
),
column(
width = 2,
p("Custom sense weighting")
),
column(
width = 1,
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,
p("Download results as Excel workbook")
)
),
plotlyOutput("layer1", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Processes"),
plotlyOutput("layer2", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Services"),
plotlyOutput("layer3", height = "270px") %>% withSpinner()
),
tabItem(
tabName = "3", 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),
shinyBS::bsTooltip("bbnDisplayNames", "Four MESO models have been defined thus far")
),
column(
width = 4,
checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE),
shinyBS::bsTooltip("bbnDisplayEdges", "Edges are removed")
),
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")
)
)
)
)
)
)
) )
server <- function(input, output, session) { server <- function(input, output, session) {
#SERVER Constants # SERVER Constants
print("Loading data") print("Loading data")
dataStorage <- "data/" dataStorage <- "data/"
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
@@ -254,7 +259,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 +267,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 +289,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("\\)", "") %>%
@@ -287,14 +303,14 @@ server <- function(input, output, session) {
setNewNames <- function(wb, habName) { setNewNames <- function(wb, habName) {
#habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5)) # habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
print(habName) 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(possNames$node)
print(newNodes$node) print(newNodes$node)
@@ -318,13 +334,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) # 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) print(habName)
@@ -334,27 +349,25 @@ 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") # save(tmp, file = "tmp.RData")
cnt <- cnt+1 cnt <- cnt + 1
} }
} }
#save(modelList, file="models.RData") # 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") # save(modelList, file = "model.RData")
#print(load("modelList.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 +387,27 @@ 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
#save(pressStatus, thisModel, file="beforeWeight.RData") # save(pressStatus, thisModel, file="beforeWeight.RData")
if (sum(pressStatus$status=="On")>0) { 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") # 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 +421,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 +439,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,19 +461,18 @@ 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 # .selections$runOnce <<- TRUE
}) })
observeEvent(reactiveValuesToList(input), { observeEvent(reactiveValuesToList(input), {
isolate(myList <- reactiveValuesToList(input)) isolate(myList <- reactiveValuesToList(input))
matches <- match(pressures$code, names(myList)) matches <- match(pressures$code, names(myList))
if (length(matches) > 0) { if (length(matches) > 0) {
status <- NULL status <- NULL
@@ -471,14 +482,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,19 +497,19 @@ 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)
@@ -507,7 +517,7 @@ server <- function(input, output, session) {
}) })
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,35 +527,34 @@ 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( {
sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step = 0.01), tagList(
sliderInput("l1L", "Low Sensitivity/High resistance", 0.15, 0.5, abs(.resistanceScores[2]), step = 0.01), sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step = 0.01),
sliderInput("l1M", "Medium Sensitivity/Med resistance", 0.5, 0.75, abs(.resistanceScores[3]), step = 0.01), sliderInput("l1L", "Low Sensitivity/High resistance", 0.15, 0.5, abs(.resistanceScores[2]), step = 0.01),
sliderInput("l1H", "High Sensitivity/Low resistance", 0.75, 1.0, abs(.resistanceScores[4]), step = 0.01), sliderInput("l1M", "Medium Sensitivity/Med resistance", 0.5, 0.75, abs(.resistanceScores[3]), step = 0.01),
sliderInput("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step = 0.01), sliderInput("l1H", "High Sensitivity/Low resistance", 0.75, 1.0, abs(.resistanceScores[4]), step = 0.01),
sliderInput("ssgr", "Zero intercept", -0.1, 0.1,.resistanceScores[6], step = 0.01), sliderInput("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step = 0.01),
sliderInput("l1PressSD", "Std Dev", 0.1, 1.0, .resistanceScores[7], 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)
}, )
title = "Layer 1 controls", },
footer = tagList( title = "Layer 1 controls",
modalButton("Cancel"), footer = tagList(
actionButton("modalOK", "OK") modalButton("Cancel"),
), 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 +566,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,29 +630,28 @@ 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") # 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
} }
@@ -662,18 +669,18 @@ 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({ # observe({
# visNetworkProxy("bbnGraphPlot") %>% # visNetworkProxy("bbnGraphPlot") %>%
# visStabilize(iterations = 10) # visStabilize(iterations = 10)
#}) # })
getModelName <- function() { getModelName <- function() {
paste0("data/", input$modelSelect, ".xlsx") paste0("data/", input$modelSelect, ".xlsx")
@@ -682,34 +689,35 @@ server <- function(input, output, session) {
genPlot <- function(boxPlot, title, paletteLength) { genPlot <- function(boxPlot, title, paletteLength) {
if (nrow(boxPlot) > 0) { if (nrow(boxPlot) > 0) {
#print(paste('Palette length', paletteLength)) # print(paste('Palette length', paletteLength))
#palette <- brewer.pal(paletteLength, "Set3") # palette <- brewer.pal(paletteLength, "Set3")
#palette <- c("red", "sienna3", "plum2", "rosybrown4", "sandybrown", "yellow", "seashell3", "palegreen", "springgreen4", "steelblue", "azure") # 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))) # print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
#cat(colours) # cat(colours)
xform <- list(categoryorder = "array", xform <- list(
categoryarray = boxPlot[,1], categoryorder = "array",
zerolinewidth = 10) categoryarray = boxPlot[, 1],
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(dtick=0.25, range=c(-1.25, 1.25)), 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 = "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)
} }
} }
@@ -727,16 +735,20 @@ server <- function(input, output, session) {
}) })
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 +760,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()
) )
) )
@@ -826,13 +840,13 @@ server <- function(input, output, session) {
settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE), settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE),
likelihoods = makeLikelihoods() likelihoods = makeLikelihoods()
) )
xl <- write.xlsx(l, "dataset.xlsx") xl <- write.xlsx(l, "dataset.xlsx")
#zipFile <- zipr(file, c("dataset.xlsx")) # zipFile <- zipr(file, c("dataset.xlsx"))
file.copy("dataset.xlsx", file) file.copy("dataset.xlsx", file)
#print(paste("zip file complete", zipFile)) # print(paste("zip file complete", zipFile))
setwd(oldDir) setwd(oldDir)
unlink(tmp) unlink(tmp)
@@ -841,8 +855,6 @@ server <- function(input, output, session) {
}, },
contentType = "application/xlsx" contentType = "application/xlsx"
) )
} }
shinyApp(ui, server) shinyApp(ui, server)

92
extract.R
View File

@@ -1,16 +1,20 @@
#R script to upload the existing spreadsheets and homologise them # R script to upload the existing spreadsheets and homologise them
library(magrittr) library(magrittr)
fList <- list.files("data", pattern="*.xlsx") fList <- list.files("data", pattern = "*.xlsx")
#Objective to create data tables with # 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 +25,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 +46,43 @@ 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 # get pressure names
#Drop the time column no use at all.... # Drop the time column no use at all....
sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[1])[ ,-1] 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] sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[4])[, -1]
op_check <- na.omit(sheet[,1:2]) op_check <- na.omit(sheet[, 1:2])
sheet2 <- na.omit(sheet[, -c(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)),
@@ -87,25 +93,21 @@ for (wbIdx in 1:length(fList)) {
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") save(newNameMap, file = "nameMap.RData")
} }

119
reWeight.R
View File

@@ -1,123 +1,127 @@
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]) # 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) # 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)
}
# print(paste(idx, paste(newValues, collapse=",")))
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,
edgesTib, incode,
incode, outcode,
outcode, value) {
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) 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])) print(paste(ref, edgesTib$values[ref], value[idx]))
edgesTib$values[ref] <- value[idx] edgesTib$values[ref] <- value[idx]
#Set the appropriate values # 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("before")
print(sum(p_on$values)) 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)
@@ -128,5 +132,4 @@ reWeightModel <- function(thisNet, pressStatus) {
print("exitting reweighting process") print("exitting reweighting process")
return(thisNet) return(thisNet)
} }