StyleR run
This commit is contained in:
130
Parses.R
130
Parses.R
@@ -5,7 +5,7 @@ modules::import(stringr)
|
||||
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
|
||||
|
||||
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) {
|
||||
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))
|
||||
}
|
||||
|
||||
@@ -31,7 +31,7 @@ delNA <- function(vec) {
|
||||
}
|
||||
|
||||
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
|
||||
expr <- "("
|
||||
for (p in 1:nrow(pressStatus)) {
|
||||
@@ -58,7 +58,7 @@ parseScenario <- function(press, prefix = "p") {
|
||||
dimnames = list(NULL, c("growth", "confidence", "layer"))
|
||||
)
|
||||
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
|
||||
if (sum(duplicated(pressNames)) > 0) {
|
||||
@@ -71,9 +71,9 @@ parseScenario <- function(press, prefix = "p") {
|
||||
nodes = data.frame(
|
||||
name = pressNames,
|
||||
code = paste0(prefix, seq(1:length(pressNames))),
|
||||
growth = coefs[,"growth"],
|
||||
confidence = coefs[,"confidence"],
|
||||
layer = coefs[,"layer"],
|
||||
growth = coefs[, "growth"],
|
||||
confidence = coefs[, "confidence"],
|
||||
layer = coefs[, "layer"],
|
||||
stringsAsFactors = FALSE
|
||||
),
|
||||
edges = data.frame(input = NULL, output = NULL, impact = NULL)
|
||||
@@ -85,7 +85,6 @@ getInitial <- function(string, letter) {
|
||||
}
|
||||
|
||||
split <- function(cell) {
|
||||
|
||||
params <- unlist(strsplit(cell, ","))
|
||||
values <- rep(0, length(states))
|
||||
|
||||
@@ -96,7 +95,7 @@ split <- function(cell) {
|
||||
if ((ref > 0) & (ref <= length(values))) {
|
||||
values[ref] <- kvp[2]
|
||||
} else {
|
||||
print(paste("Unrecognised parameter(s):",params[n]))
|
||||
print(paste("Unrecognised parameter(s):", params[n]))
|
||||
}
|
||||
}
|
||||
|
||||
@@ -119,18 +118,18 @@ getOutNodes <- function(codes, codeList) {
|
||||
|
||||
buildGraph <- function(model, desc) {
|
||||
|
||||
#model contains the following
|
||||
# model contains the following
|
||||
# node table, edge table
|
||||
|
||||
#descriptor (desc) contains:
|
||||
#inputCode - the top layer of the model
|
||||
#outputCodes - all subsequent layers to be included in the model
|
||||
# descriptor (desc) contains:
|
||||
# inputCode - the top layer of the model
|
||||
# outputCodes - all subsequent layers to be included in the model
|
||||
|
||||
|
||||
inputNodes <- model$nodes$code[which(startsWith(model$nodes$code, desc$inputCode))]
|
||||
inputText <- paste0("[", inputNodes, "]", collapse = "")
|
||||
|
||||
#do the internal nodes
|
||||
# do the internal nodes
|
||||
edges <- ""
|
||||
|
||||
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])
|
||||
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(
|
||||
c(model$nodes$growth[nodeRef], model$edges$values[rows]),
|
||||
c("(Intercept)", model$edges$input[rows])
|
||||
)
|
||||
#str(coefVal)
|
||||
# str(coefVal)
|
||||
outDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[nodeRef])
|
||||
}
|
||||
|
||||
print("Saving model prior to network modelling")
|
||||
modelDefn <- paste0(inputText, edges)
|
||||
save(modelDefn, file="buildGraph.RData")
|
||||
save(modelDefn, file = "buildGraph.RData")
|
||||
|
||||
|
||||
#print("about to build network")
|
||||
#print(paste0(inputText, edges))
|
||||
# print("about to build network")
|
||||
# print(paste0(inputText, edges))
|
||||
|
||||
|
||||
|
||||
@@ -176,15 +175,15 @@ buildGraph <- function(model, desc) {
|
||||
|
||||
allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes)))
|
||||
|
||||
#print(allDists)
|
||||
# print(allDists)
|
||||
cfit <- custom.fit(net, allDists)
|
||||
|
||||
cat("about to calculate sample distributions")
|
||||
#print(outNodes)
|
||||
# print(outNodes)
|
||||
|
||||
sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw")
|
||||
summDists <- summary(sampleDists)
|
||||
#stdDev <- sd(sampleDists)
|
||||
# stdDev <- sd(sampleDists)
|
||||
|
||||
print("sample distribution build successful")
|
||||
|
||||
@@ -206,11 +205,11 @@ buildGraph <- function(model, desc) {
|
||||
|
||||
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
|
||||
inputNodes <- mapping[2:nrow(mapping), 1]
|
||||
|
||||
#check that all input nodes are in the previous table
|
||||
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 (sum(inputNodes %in% prevOutputs$name) < length(inputNodes)) {
|
||||
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)])
|
||||
if (length(validInputs) == 0) {
|
||||
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"])
|
||||
|
||||
if (sum(duplicated(inputInts))>0) {
|
||||
if (sum(duplicated(inputInts)) > 0) {
|
||||
cat("Duplicated input node names found")
|
||||
print(inputNodes[duplicated(inputNodes)])
|
||||
}
|
||||
@@ -242,10 +241,10 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
|
||||
}
|
||||
|
||||
|
||||
#check that all internal nodes are in the columns
|
||||
intNodes <- delNA(mapping[mapping[,"Node.Type"] == "internal", "Nodes"])
|
||||
# check that all internal nodes are in the columns
|
||||
intNodes <- delNA(mapping[mapping[, "Node.Type"] == "internal", "Nodes"])
|
||||
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")
|
||||
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")))
|
||||
for (idx in 1:length(outNodes)) {
|
||||
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(
|
||||
code = c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))),
|
||||
name = c(prevOutputs$name, outNodes),
|
||||
growth = c(prevOutputs$growth, coefs[,"growth"]),
|
||||
confidence = c(prevOutputs$confidence, coefs[,"confidence"]),
|
||||
layer = c(prevOutputs$layer, coefs[,"layer"]),
|
||||
growth = c(prevOutputs$growth, coefs[, "growth"]),
|
||||
confidence = c(prevOutputs$confidence, coefs[, "confidence"]),
|
||||
layer = c(prevOutputs$layer, coefs[, "layer"]),
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
}
|
||||
@@ -272,66 +271,67 @@ getCode <- function(name, nodeDF) {
|
||||
}
|
||||
|
||||
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")
|
||||
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)) {
|
||||
count <- 0
|
||||
|
||||
for (row in 2:nrow(mapping)) {
|
||||
|
||||
if (!is.na(mapping[row, col])) {
|
||||
edgeM <- rbind(edgeM,
|
||||
c(getCode(mapping[row, 1], nodeDF),
|
||||
edgeM <- rbind(
|
||||
edgeM,
|
||||
c(
|
||||
getCode(mapping[row, 1], nodeDF),
|
||||
getCode(colnames(mapping)[col], nodeDF),
|
||||
split(mapping[row,col])[match("impact", states)]
|
||||
split(mapping[row, col])[match("impact", states)]
|
||||
)
|
||||
)
|
||||
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)) {
|
||||
return (data.frame(
|
||||
input = edgeM[,"inputNode"],
|
||||
output = edgeM[,"outputNode"],
|
||||
impact = edgeM[,"impact"],
|
||||
return(data.frame(
|
||||
input = edgeM[, "inputNode"],
|
||||
output = edgeM[, "outputNode"],
|
||||
impact = edgeM[, "impact"],
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
} else {
|
||||
return (data.frame(
|
||||
input = c(prevEdge$input, edgeM[,"inputNode"]),
|
||||
output = c(prevEdge$output, edgeM[,"outputNode"]),
|
||||
impact = c(prevEdge$impact, edgeM[,"impact"]),
|
||||
return(data.frame(
|
||||
input = c(prevEdge$input, edgeM[, "inputNode"]),
|
||||
output = c(prevEdge$output, edgeM[, "outputNode"]),
|
||||
impact = c(prevEdge$impact, edgeM[, "impact"]),
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
}
|
||||
}
|
||||
|
||||
parseMapping <- function(mapping, prevOutputs, prefix) {
|
||||
mapping <- mapping[,-1]
|
||||
mapping[,1] <- cleanTitles(mapping[,1])
|
||||
mapping <- mapping[, -1]
|
||||
mapping[, 1] <- cleanTitles(mapping[, 1])
|
||||
|
||||
nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix)
|
||||
edgeDF <- getValidEdges(mapping, nodeDF, prevEdge = prevOutputs$edges, prefix)
|
||||
|
||||
#save(nodeDF, edgeDF, file="mapping.RData")
|
||||
# save(nodeDF, edgeDF, file="mapping.RData")
|
||||
|
||||
return(list(
|
||||
#New structure
|
||||
# New structure
|
||||
nodes = nodeDF,
|
||||
edges = edgeDF
|
||||
))
|
||||
}
|
||||
|
||||
parseSheet <- function(fName) {
|
||||
#get sheet names
|
||||
# get sheet names
|
||||
|
||||
print(paste("starting sheet load", fName))
|
||||
|
||||
@@ -339,19 +339,18 @@ parseSheet <- function(fName) {
|
||||
names <- openxlsx::getSheetNames(fName)
|
||||
|
||||
if (length(names) > 0) {
|
||||
|
||||
sheets <- sort(delNA(match(names, mappings)))
|
||||
|
||||
cat("starting sheet parse")
|
||||
#print(sheets)
|
||||
# print(sheets)
|
||||
|
||||
if (sum(sheets == refs) == length(refs)) {
|
||||
#read all mapping tables
|
||||
scenario <- parseScenario(readXL(fName,mappings[1], startRow = 1), prefix = "p")
|
||||
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_es <- parseMapping(readXL(fName,mappings[4], startRow = 1), p_op, prefix = "es")
|
||||
legend <- readXL(fName,mappings[5], startRow = 1)
|
||||
# read all mapping tables
|
||||
scenario <- parseScenario(readXL(fName, mappings[1], startRow = 1), prefix = "p")
|
||||
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_es <- parseMapping(readXL(fName, mappings[4], startRow = 1), p_op, prefix = "es")
|
||||
legend <- readXL(fName, mappings[5], startRow = 1)
|
||||
|
||||
print("sheet load completed")
|
||||
return(
|
||||
@@ -360,7 +359,6 @@ parseSheet <- function(fName) {
|
||||
legend = legend
|
||||
)
|
||||
)
|
||||
|
||||
} else {
|
||||
print(paste("Sheets found include", mappings[sheets]))
|
||||
cat("Missing sheets are:")
|
||||
|
||||
286
app.R
286
app.R
@@ -31,8 +31,8 @@ impLabels <- c("Very High", "High", "Medium", "Low", "Very Low")
|
||||
|
||||
|
||||
ui <- dashboardPage(
|
||||
|
||||
dashboardHeader(title = "JNCC MESO online",
|
||||
dashboardHeader(
|
||||
title = "JNCC MESO online",
|
||||
tags$li(
|
||||
id = "dropdownHelp",
|
||||
class = "dropdown",
|
||||
@@ -80,15 +80,16 @@ ui <- dashboardPage(
|
||||
)
|
||||
),
|
||||
dashboardSidebar(
|
||||
sidebarMenu(id = "tabs",
|
||||
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")),
|
||||
# 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")),
|
||||
# downloadButton("download", "", icon = icon("download")),
|
||||
uiOutput("pressureList")
|
||||
)
|
||||
),
|
||||
@@ -127,8 +128,10 @@ ui <- dashboardPage(
|
||||
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$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",
|
||||
@@ -145,7 +148,8 @@ ui <- dashboardPage(
|
||||
"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(
|
||||
column(
|
||||
width = 6,
|
||||
@@ -175,7 +179,8 @@ ui <- dashboardPage(
|
||||
h4("Effect on Ecosystem Services"),
|
||||
plotlyOutput("layer3", height = "270px") %>% withSpinner()
|
||||
),
|
||||
tabItem(tabName = "3",h2("Bayesian Network"),
|
||||
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(
|
||||
@@ -216,7 +221,7 @@ ui <- dashboardPage(
|
||||
)
|
||||
|
||||
server <- function(input, output, session) {
|
||||
#SERVER Constants
|
||||
# SERVER Constants
|
||||
|
||||
print("Loading data")
|
||||
|
||||
@@ -254,7 +259,7 @@ server <- function(input, output, session) {
|
||||
|
||||
.selections <- reactiveValues(
|
||||
model = 1,
|
||||
#runOnce = FALSE,
|
||||
# runOnce = FALSE,
|
||||
bbnImpact = 1,
|
||||
bbnNames = FALSE,
|
||||
bbnEdges = FALSE,
|
||||
@@ -262,11 +267,21 @@ server <- function(input, output, session) {
|
||||
)
|
||||
|
||||
getImpact <- function(v) {
|
||||
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
|
||||
if ((v == "HR") || (v == "III")) 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])
|
||||
if ((v == "INS") || (v == "IV")) {
|
||||
return(.resistanceScores[1])
|
||||
}
|
||||
if ((v == "HR") || (v == "III")) {
|
||||
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)
|
||||
}
|
||||
|
||||
@@ -274,10 +289,11 @@ server <- function(input, output, session) {
|
||||
dplyr::select(hab, nodeType, Suggestion, node, newname)
|
||||
|
||||
newNameMap$hab <- stringr::str_replace_all(newNameMap$hab, "_", " ")
|
||||
#save(newNameMap, file="nameMap.RData")
|
||||
# save(newNameMap, file="nameMap.RData")
|
||||
|
||||
stripStr <- function(nodeStr) {
|
||||
nodeStr %>% stringr::str_replace_all("\\.", "") %>%
|
||||
nodeStr %>%
|
||||
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) {
|
||||
|
||||
#habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
|
||||
# habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
|
||||
|
||||
print(habName)
|
||||
possNames <- newNameMap %>%
|
||||
dplyr::filter(hab==habName) %>%
|
||||
dplyr::mutate(node=stripStr(node))
|
||||
dplyr::filter(hab == habName) %>%
|
||||
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)
|
||||
@@ -318,13 +334,12 @@ server <- function(input, output, session) {
|
||||
print(paste("attempting to load", 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)
|
||||
|
||||
if (!is.null(wb)) {
|
||||
|
||||
habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5)) %>%
|
||||
habName <- substr(fileList[idx], 1, (nchar(fileList[idx]) - 5)) %>%
|
||||
stringr::str_replace_all("_", " ")
|
||||
print(habName)
|
||||
|
||||
@@ -334,27 +349,25 @@ server <- function(input, output, session) {
|
||||
models <<- c(models, habName)
|
||||
print(paste("Model file successfully loaded", fileList[idx]))
|
||||
|
||||
#save(tmp, file = "tmp.RData")
|
||||
cnt <- cnt+1
|
||||
# save(tmp, file = "tmp.RData")
|
||||
cnt <- cnt + 1
|
||||
}
|
||||
}
|
||||
#save(modelList, file="models.RData")
|
||||
# save(modelList, file="models.RData")
|
||||
updateSelectInput(session, "modelSelect", choices = models)
|
||||
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()
|
||||
|
||||
save(modelList, file="model.RData")
|
||||
# save(modelList, file = "model.RData")
|
||||
|
||||
#print(load("modelList.RData"))
|
||||
# print(load("modelList.RData"))
|
||||
|
||||
|
||||
calcLikelihood <- function(layer, pressStatus, forPlotly) {
|
||||
|
||||
isolate({
|
||||
|
||||
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$confidence <<- .resistanceScores["pressSD"]
|
||||
@@ -374,27 +387,27 @@ server <- function(input, output, session) {
|
||||
|
||||
expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ")
|
||||
}
|
||||
expr <- substr(expr, 1, nchar(expr)-2)
|
||||
expr <- substr(expr, 1, nchar(expr) - 2)
|
||||
expr <- paste0(expr, ")")
|
||||
|
||||
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
|
||||
|
||||
|
||||
#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)
|
||||
} #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")))
|
||||
|
||||
@@ -408,17 +421,17 @@ server <- function(input, output, session) {
|
||||
)
|
||||
})
|
||||
|
||||
#print(sampleDists)
|
||||
# print(sampleDists)
|
||||
|
||||
#displayCols <- match(nodeCodes, colnames(sampleDists))
|
||||
sampleDists <- round(sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits=2)
|
||||
# displayCols <- match(nodeCodes, colnames(sampleDists))
|
||||
sampleDists <- round(sampleDists[, match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits = 2)
|
||||
|
||||
means <- apply(sampleDists, 2, mean)
|
||||
stdDev <- apply(sampleDists, 2, sd)
|
||||
#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)))
|
||||
#str(quantiles)
|
||||
# str(quantiles)
|
||||
|
||||
if (forPlotly) {
|
||||
return(data.frame(
|
||||
@@ -426,19 +439,18 @@ server <- function(input, output, session) {
|
||||
code = thisModel$p_es$nodes$code,
|
||||
layer = thisModel$p_es$nodes$layer,
|
||||
range = c(
|
||||
#apply(sampleDists, 2, min),
|
||||
quantiles[,1],
|
||||
quantiles[,2],
|
||||
quantiles[,2],
|
||||
quantiles[,3],
|
||||
quantiles[,4],
|
||||
quantiles[,4],
|
||||
quantiles[,5]
|
||||
# apply(sampleDists, 2, min),
|
||||
quantiles[, 1],
|
||||
quantiles[, 2],
|
||||
quantiles[, 2],
|
||||
quantiles[, 3],
|
||||
quantiles[, 4],
|
||||
quantiles[, 4],
|
||||
quantiles[, 5]
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
} else {
|
||||
|
||||
return(data.frame(
|
||||
name = thisModel$p_es$nodes$name,
|
||||
code = thisModel$p_es$nodes$code,
|
||||
@@ -449,14 +461,13 @@ server <- function(input, output, session) {
|
||||
maxes = apply(sampleDists, 2, max),
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
observeEvent(input$modelSelect, {
|
||||
.selections$model <<- match(input$modelSelect, models)
|
||||
#.selections$runOnce <<- TRUE
|
||||
# .selections$runOnce <<- TRUE
|
||||
})
|
||||
|
||||
observeEvent(reactiveValuesToList(input), {
|
||||
@@ -471,14 +482,13 @@ server <- function(input, output, session) {
|
||||
|
||||
newStatus <- data.frame(code = pressures$code, status = status, stringsAsFactors = FALSE)
|
||||
|
||||
if (!identical(newStatus, .selections$pressStatus)) { #} || .selections$runOnce) {
|
||||
#.selections$runOnce = FALSE
|
||||
if (!identical(newStatus, .selections$pressStatus)) { # } || .selections$runOnce) {
|
||||
# .selections$runOnce = FALSE
|
||||
print("Running calc")
|
||||
.likelihoods$p_es <<- calcLikelihood(0, newStatus, TRUE)
|
||||
|
||||
.selections$pressStatus <<- newStatus
|
||||
}
|
||||
|
||||
}
|
||||
})
|
||||
|
||||
@@ -487,19 +497,19 @@ server <- function(input, output, session) {
|
||||
}
|
||||
|
||||
output$pressureList <- renderUI({
|
||||
#isolate({
|
||||
# isolate({
|
||||
if (!is.null(modelList[[.selections$model]]$p_es$nodes)) {
|
||||
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(
|
||||
code = modelList[[.selections$model]]$p_es$nodes$code[pressCodes],
|
||||
name = modelList[[.selections$model]]$p_es$nodes$name[pressCodes],
|
||||
#status = status,
|
||||
# status = status,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
#This assumes all pressures are the same...
|
||||
# This assumes all pressures are the same...
|
||||
|
||||
setPressures(pressures)
|
||||
btnList <- apply(pressures, 1, makeRadioButtons)
|
||||
@@ -507,7 +517,7 @@ server <- function(input, output, session) {
|
||||
})
|
||||
|
||||
observeEvent(input$bbnImpactSelect, {
|
||||
#filter nodes and edges to
|
||||
# filter nodes and edges to
|
||||
.selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)]
|
||||
})
|
||||
|
||||
@@ -517,20 +527,20 @@ server <- function(input, output, session) {
|
||||
|
||||
observeEvent(input$bbnDisplayEdges, {
|
||||
.selections$bbnEdges <- input$bbnDisplayEdges
|
||||
|
||||
})
|
||||
|
||||
|
||||
observeEvent(input$layer1Slider, {
|
||||
showModal(
|
||||
modalDialog({
|
||||
modalDialog(
|
||||
{
|
||||
tagList(
|
||||
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("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("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)
|
||||
)
|
||||
},
|
||||
@@ -539,13 +549,12 @@ server <- function(input, output, session) {
|
||||
modalButton("Cancel"),
|
||||
actionButton("modalOK", "OK")
|
||||
),
|
||||
size = "s")
|
||||
size = "s"
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
observeEvent(input$modalOK, {
|
||||
|
||||
|
||||
.resistanceScores["nr"] <<- -input$l1VH
|
||||
.resistanceScores["lr"] <<- -input$l1H
|
||||
.resistanceScores["mr"] <<- -input$l1M
|
||||
@@ -557,7 +566,6 @@ server <- function(input, output, session) {
|
||||
|
||||
.likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus, TRUE)
|
||||
removeModal()
|
||||
|
||||
})
|
||||
|
||||
|
||||
@@ -622,29 +630,28 @@ server <- function(input, output, session) {
|
||||
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) {
|
||||
#do pressures
|
||||
# do pressures
|
||||
edgeNet <- edges[edges$from %in% nodeNet$id, ]
|
||||
idx <- 1
|
||||
repeat {
|
||||
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 <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id),]
|
||||
edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id), ]
|
||||
|
||||
idx <- idx + 1
|
||||
if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break
|
||||
nodeNet <- rbind(nodeNet, nodesToAdd)
|
||||
edgeNet <- rbind(edgeNet, edgesToAdd)
|
||||
|
||||
} #until finished
|
||||
} # until finished
|
||||
} else {
|
||||
edgeNet <- edges
|
||||
}
|
||||
@@ -662,18 +669,18 @@ server <- function(input, output, session) {
|
||||
visExport() %>%
|
||||
visLegend(useGroups = FALSE, addNodes = legendDF) %>%
|
||||
visHierarchicalLayout(nodeSpacing = nodeSpacing, direction = "LR") %>%
|
||||
visOptions(highlightNearest = TRUE) #%>%
|
||||
#visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
|
||||
visOptions(highlightNearest = TRUE) # %>%
|
||||
# visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
|
||||
}
|
||||
|
||||
output$bbnGraphPlot <- renderVisNetwork({
|
||||
makeBbnGraph(modelList[[.selections$model]])
|
||||
})
|
||||
|
||||
#observe({
|
||||
# observe({
|
||||
# visNetworkProxy("bbnGraphPlot") %>%
|
||||
# visStabilize(iterations = 10)
|
||||
#})
|
||||
# })
|
||||
|
||||
getModelName <- function() {
|
||||
paste0("data/", input$modelSelect, ".xlsx")
|
||||
@@ -682,34 +689,35 @@ server <- function(input, output, session) {
|
||||
genPlot <- function(boxPlot, title, paletteLength) {
|
||||
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)
|
||||
|
||||
#print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
|
||||
#cat(colours)
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = boxPlot[,1],
|
||||
zerolinewidth = 10)
|
||||
# print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
|
||||
# cat(colours)
|
||||
xform <- list(
|
||||
categoryorder = "array",
|
||||
categoryarray = boxPlot[, 1],
|
||||
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)
|
||||
|
||||
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)
|
||||
}
|
||||
}
|
||||
|
||||
prepPlot <- function(code = "ba", name = "Functional Group") {
|
||||
if (!is.null(.likelihoods$p_es)) {
|
||||
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")
|
||||
title <- paste(input$modelSelect, name, "Box Plot")
|
||||
paletteLength <- nrow(modelList[[.selections$model]]$legend)
|
||||
#print(paste('prep plot palette', paletteLength))
|
||||
# print(paste('prep plot palette', paletteLength))
|
||||
genPlot(thisPlot, title, paletteLength)
|
||||
}
|
||||
}
|
||||
@@ -727,16 +735,20 @@ server <- function(input, output, session) {
|
||||
})
|
||||
|
||||
|
||||
isAbsolutePath = function( path ){
|
||||
if( path == "~" )
|
||||
return(TRUE);
|
||||
if( grepl("^~/", path) )
|
||||
return(TRUE);
|
||||
if( grepl("^.:(/|\\\\)", path) )
|
||||
return(TRUE);
|
||||
if( grepl("^(/|\\\\)", path) )
|
||||
return(TRUE);
|
||||
return(FALSE);
|
||||
isAbsolutePath <- function(path) {
|
||||
if (path == "~") {
|
||||
return(TRUE)
|
||||
}
|
||||
if (grepl("^~/", path)) {
|
||||
return(TRUE)
|
||||
}
|
||||
if (grepl("^.:(/|\\\\)", path)) {
|
||||
return(TRUE)
|
||||
}
|
||||
if (grepl("^(/|\\\\)", path)) {
|
||||
return(TRUE)
|
||||
}
|
||||
return(FALSE)
|
||||
}
|
||||
|
||||
output$linkBackgroundData <- downloadHandler(
|
||||
@@ -748,66 +760,68 @@ server <- function(input, output, session) {
|
||||
)
|
||||
|
||||
makeLikelihoods <- function() {
|
||||
|
||||
|
||||
likeliTab <- as.data.frame(
|
||||
cbind(
|
||||
.likelihoods$p_es, codeVal = sapply(
|
||||
.likelihoods$p_es,
|
||||
codeVal = sapply(
|
||||
.likelihoods$p_es$code, function(str) {
|
||||
if (startsWith(str, 'p')) as.numeric(substring(str, 2, nchar(str)))
|
||||
else as.numeric(substring(str, 3, nchar(str)))
|
||||
if (startsWith(str, "p")) {
|
||||
as.numeric(substring(str, 2, nchar(str)))
|
||||
} else {
|
||||
as.numeric(substring(str, 3, nchar(str)))
|
||||
}
|
||||
)),
|
||||
stringsAsFactors=FALSE
|
||||
}
|
||||
)
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
likeliTab <- arrange(likeliTab, layer, codeVal)
|
||||
|
||||
outputRows <- trunc(nrow(likeliTab)/7)
|
||||
outputRows <- trunc(nrow(likeliTab) / 7)
|
||||
outputTab <- NULL
|
||||
|
||||
for (idx in 1:outputRows) {
|
||||
elementRow <- (idx - 1) * 7 + 1
|
||||
|
||||
tabRow <-c(
|
||||
tabRow <- c(
|
||||
name = likeliTab$name[elementRow],
|
||||
code = likeliTab$code[elementRow],
|
||||
layer = likeliTab$layer[elementRow],
|
||||
min=likeliTab$range[elementRow],
|
||||
q1 =likeliTab$range[elementRow+2],
|
||||
median =likeliTab$range[elementRow+3],
|
||||
q3 =likeliTab$range[elementRow+4],
|
||||
max =likeliTab$range[elementRow+6]
|
||||
min = likeliTab$range[elementRow],
|
||||
q1 = likeliTab$range[elementRow + 2],
|
||||
median = likeliTab$range[elementRow + 3],
|
||||
q3 = likeliTab$range[elementRow + 4],
|
||||
max = likeliTab$range[elementRow + 6]
|
||||
)
|
||||
outputTab <- rbind(outputTab, tabRow)
|
||||
|
||||
}
|
||||
|
||||
likelihoods <- data.frame(
|
||||
name = outputTab[,1],
|
||||
code = outputTab[,2],
|
||||
layer = as.numeric(outputTab[,3]),
|
||||
max =as.numeric(outputTab[,8]),
|
||||
q3 =as.numeric(outputTab[,7]),
|
||||
median =as.numeric(outputTab[,6]),
|
||||
q1 =as.numeric(outputTab[,5]),
|
||||
min=as.numeric(outputTab[,4]),
|
||||
name = outputTab[, 1],
|
||||
code = outputTab[, 2],
|
||||
layer = as.numeric(outputTab[, 3]),
|
||||
max = as.numeric(outputTab[, 8]),
|
||||
q3 = as.numeric(outputTab[, 7]),
|
||||
median = as.numeric(outputTab[, 6]),
|
||||
q1 = as.numeric(outputTab[, 5]),
|
||||
min = as.numeric(outputTab[, 4]),
|
||||
stringsAsFactors = FALSE,
|
||||
row.names = NULL
|
||||
)
|
||||
}
|
||||
|
||||
output$download <- downloadHandler(
|
||||
|
||||
filename = function() { paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx") },
|
||||
filename = function() {
|
||||
paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx")
|
||||
},
|
||||
content = function(file) {
|
||||
|
||||
showModal(
|
||||
modalDialog(
|
||||
fluidRow(
|
||||
column(width = 12) %>% withSpinner(type = 5, proxy.height = "200px")
|
||||
),
|
||||
footer=div()
|
||||
footer = div()
|
||||
)
|
||||
)
|
||||
|
||||
@@ -828,11 +842,11 @@ server <- function(input, output, session) {
|
||||
)
|
||||
xl <- write.xlsx(l, "dataset.xlsx")
|
||||
|
||||
#zipFile <- zipr(file, c("dataset.xlsx"))
|
||||
# zipFile <- zipr(file, c("dataset.xlsx"))
|
||||
|
||||
file.copy("dataset.xlsx", file)
|
||||
|
||||
#print(paste("zip file complete", zipFile))
|
||||
# print(paste("zip file complete", zipFile))
|
||||
|
||||
setwd(oldDir)
|
||||
unlink(tmp)
|
||||
@@ -841,8 +855,6 @@ server <- function(input, output, session) {
|
||||
},
|
||||
contentType = "application/xlsx"
|
||||
)
|
||||
|
||||
|
||||
}
|
||||
|
||||
shinyApp(ui, server)
|
||||
|
||||
90
extract.R
90
extract.R
@@ -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)
|
||||
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) {
|
||||
nodeString <- stringr::str_replace_all(nodeString, "\\.", " ")
|
||||
res <- sapply(nodeString, match, nodeStringCheck$Nodes) %>% is.na() %>% which()
|
||||
if (length(res)>0) print(paste("Clean up error found in", nodeType, "mapping at", names(res)))
|
||||
res <- sapply(nodeString, match, nodeStringCheck$Nodes) %>%
|
||||
is.na() %>%
|
||||
which()
|
||||
if (length(res) > 0) print(paste("Clean up error found in", nodeType, "mapping at", names(res)))
|
||||
}
|
||||
|
||||
getNodeVals <- function(nodeStr) {
|
||||
params <- stringr::str_split(nodeStr, ",") %>% unlist() %>% trimws()
|
||||
params <- stringr::str_split(nodeStr, ",") %>%
|
||||
unlist() %>%
|
||||
trimws()
|
||||
paramVals <- stringr::str_split(params, "=")
|
||||
vals <- c()
|
||||
lapply(paramVals, function(l) {
|
||||
@@ -21,18 +25,20 @@ getNodeVals <- function(nodeStr) {
|
||||
vals
|
||||
}
|
||||
|
||||
#We want to build a node table and an impact table.
|
||||
#Colnames of the node table will be
|
||||
#Hab, Node Type, Node, Node Layer, Growth, ....
|
||||
# We want to build a node table and an impact table.
|
||||
# Colnames of the node table will be
|
||||
# Hab, Node Type, Node, Node Layer, Growth, ....
|
||||
|
||||
#The edges table will be
|
||||
#Hab, In Node, Out Node, Params, ....
|
||||
# The edges table will be
|
||||
# Hab, In Node, Out Node, Params, ....
|
||||
|
||||
|
||||
sheetNames <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend")
|
||||
|
||||
cleanNames <- function(namVec) {
|
||||
stringr::str_replace_all(namVec, "\\.", " ") %>% trimws() %>% tolower()
|
||||
stringr::str_replace_all(namVec, "\\.", " ") %>%
|
||||
trimws() %>%
|
||||
tolower()
|
||||
}
|
||||
|
||||
nodeTable <- tibble::tibble()
|
||||
@@ -40,43 +46,43 @@ nodeTable <- tibble::tibble()
|
||||
for (wbIdx in 1:length(fList)) {
|
||||
wb <- openxlsx::loadWorkbook(paste0("data/", fList[wbIdx]))
|
||||
hab <- stringr::str_split(fList[wbIdx], "\\.")[[1]][1]
|
||||
#get pressure names
|
||||
# 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))
|
||||
pressure_nodes <- sheet[1,]
|
||||
pressure_nodes <- sheet[1, ]
|
||||
|
||||
|
||||
sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[2])[ ,-1]
|
||||
pressure_check <- na.omit(sheet[,1:2])
|
||||
sheet2 <- na.omit(sheet[, -c(1,2)])
|
||||
sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[2])[, -1]
|
||||
pressure_check <- na.omit(sheet[, 1:2])
|
||||
sheet2 <- na.omit(sheet[, -c(1, 2)])
|
||||
ba <- cleanNames(colnames(sheet2))
|
||||
ba_nodes <- sheet2[1,]
|
||||
pressImpact <- sheet2[-1,]
|
||||
ba_nodes <- sheet2[1, ]
|
||||
pressImpact <- sheet2[-1, ]
|
||||
|
||||
#linkCheck("pressures", pressures, pressure_check)
|
||||
# linkCheck("pressures", pressures, pressure_check)
|
||||
|
||||
|
||||
sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[3])[ ,-1]
|
||||
ba_check <- na.omit(sheet[,1:2])
|
||||
sheet2 <- na.omit(sheet[, -c(1,2)])
|
||||
sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[3])[, -1]
|
||||
ba_check <- na.omit(sheet[, 1:2])
|
||||
sheet2 <- na.omit(sheet[, -c(1, 2)])
|
||||
op <- cleanNames(colnames(sheet2))
|
||||
op_nodes <- sheet2[1,]
|
||||
baImpact <- sheet2[-1,]
|
||||
op_nodes <- 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])
|
||||
sheet2 <- na.omit(sheet[, -c(1,2)])
|
||||
sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[4])[, -1]
|
||||
op_check <- na.omit(sheet[, 1:2])
|
||||
sheet2 <- na.omit(sheet[, -c(1, 2)])
|
||||
es <- cleanNames(colnames(sheet2))
|
||||
es_nodes <- sheet2[1,]
|
||||
opImpact <- sheet2[-1,]
|
||||
es_nodes <- 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(
|
||||
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))
|
||||
res <- res %>% mutate(nodeName=names(res))
|
||||
res <- res %>% mutate(nodeName = names(res))
|
||||
|
||||
nodeTable <- nodeTable %>% dplyr::bind_rows(
|
||||
tibble::tibble(
|
||||
hab=hab,
|
||||
nodeType=nodeType,
|
||||
hab = hab,
|
||||
nodeType = nodeType,
|
||||
res
|
||||
)
|
||||
)
|
||||
|
||||
}
|
||||
|
||||
mapNewNames <- function() {
|
||||
newNameMap <- openxlsx::read.xlsx("MBA_MESO_Nodes.xlsx") %>%
|
||||
dplyr::select(hab, nodeType, Suggestion, node, newname)
|
||||
save(newNameMap, file="nameMap.RData")
|
||||
save(newNameMap, file = "nameMap.RData")
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
105
reWeight.R
105
reWeight.R
@@ -1,123 +1,127 @@
|
||||
modules::import(magrittr)
|
||||
|
||||
reWeightLayer <- function(nestedLayerTib, fudge=1) {
|
||||
|
||||
reWeightLayer <- function(nestedLayerTib, fudge = 1) {
|
||||
for (idx in 1:nrow(nestedLayerTib)) {
|
||||
#print(nestedLayerTib$data[idx])
|
||||
# print(nestedLayerTib$data[idx])
|
||||
thisData <- nestedLayerTib$data[idx][[1]]
|
||||
|
||||
#Calculate the overall depletion rate
|
||||
#depRate <- ifelse(thisData$values<0, -thisData$values, 0)
|
||||
#Re-adjust those weightings in line with the number applied
|
||||
# Calculate the overall depletion rate
|
||||
# depRate <- ifelse(thisData$values<0, -thisData$values, 0)
|
||||
# Re-adjust those weightings in line with the number applied
|
||||
survived <- 1
|
||||
grown <- 1
|
||||
for (depIdx in 1:nrow(thisData)) {
|
||||
if (thisData$values[depIdx]<0) survived <- survived * (1 + thisData$values[depIdx]) else
|
||||
grown <- (1-thisData$values[depIdx]) * grown
|
||||
if (thisData$values[depIdx] < 0) {
|
||||
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
|
||||
effGrowthRate <- 1-grown
|
||||
#print(effDepRate)
|
||||
if (sum(thisData$values)==0) newValues <- rep(0, length(thisData$values)) else
|
||||
newValues <- round(thisData$values/sum(thisData$values)*(effDepRate+effGrowthRate), digits=3)
|
||||
#print(paste(idx, paste(newValues, collapse=",")))
|
||||
effGrowthRate <- 1 - grown
|
||||
# print(effDepRate)
|
||||
if (sum(thisData$values) == 0) {
|
||||
newValues <- rep(0, length(thisData$values))
|
||||
} 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
|
||||
}
|
||||
|
||||
return(nestedLayerTib %>% tidyr::unnest(cols=c(data)))
|
||||
return(nestedLayerTib %>% tidyr::unnest(cols = c(data)))
|
||||
}
|
||||
|
||||
assignWeights <- function(
|
||||
edgesTib,
|
||||
assignWeights <- function(edgesTib,
|
||||
incode,
|
||||
outcode,
|
||||
value) {
|
||||
for (idx in 1:length(incode)) {
|
||||
ref <- intersect(which(edgesTib$input == incode[idx]),
|
||||
which(edgesTib$output == outcode[idx]))
|
||||
ref <- intersect(
|
||||
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]
|
||||
#Set the appropriate values
|
||||
|
||||
# Set the appropriate values
|
||||
}
|
||||
return(edgesTib)
|
||||
}
|
||||
|
||||
reWeightModel <- function(thisNet, pressStatus) {
|
||||
|
||||
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 %>%
|
||||
dplyr::filter(status=="On") %>%
|
||||
dplyr::left_join(thisNet$nodes, by=c("code"="code")) %>%
|
||||
dplyr::left_join(thisNet$edges, by=c("code"="input")) %>%
|
||||
dplyr::mutate(values=values * 0.9)
|
||||
dplyr::filter(status == "On") %>%
|
||||
dplyr::left_join(thisNet$nodes, by = c("code" = "code")) %>%
|
||||
dplyr::left_join(thisNet$edges, by = c("code" = "input")) %>%
|
||||
dplyr::mutate(values = values * 0.9)
|
||||
|
||||
print("before")
|
||||
print(sum(p_on$values))
|
||||
|
||||
p_on <- p_on %>%
|
||||
dplyr::rename(presscode=code) %>%
|
||||
dplyr::rename(ba_code=output) %>%
|
||||
dplyr::rename(presscode = code) %>%
|
||||
dplyr::rename(ba_code = output) %>%
|
||||
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")
|
||||
|
||||
#Repeat for the linkage between ba and op
|
||||
# Repeat for the linkage between ba and op
|
||||
bas <- unique(newP$ba_code)
|
||||
ba_impacted <- thisNet$nodes %>%
|
||||
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() %>%
|
||||
dplyr::rename(ba_code=code) %>%
|
||||
dplyr::rename(ba_code = code) %>%
|
||||
dplyr::select(layer, output, ba_code, values) %>%
|
||||
dplyr::rename(op_code=output) %>%
|
||||
tidyr::nest(data=c(ba_code, values))
|
||||
dplyr::rename(op_code = output) %>%
|
||||
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")
|
||||
|
||||
#Repeat for the linkage between op and es
|
||||
# Repeat for the linkage between op and es
|
||||
ops <- unique(newBA$op_code)
|
||||
op_impacted <- thisNet$nodes %>%
|
||||
dplyr::filter(code %in% ops) %>%
|
||||
dplyr::left_join(thisNet$edges, by=c("code"="input")) %>%
|
||||
dplyr::rename(op_code=code) %>%
|
||||
dplyr::left_join(thisNet$edges, by = c("code" = "input")) %>%
|
||||
dplyr::rename(op_code = code) %>%
|
||||
tidyr::drop_na() %>%
|
||||
dplyr::select(layer, output, op_code, values) %>%
|
||||
dplyr::rename(es_code=output) %>%
|
||||
tidyr::nest(data=c(op_code, values))
|
||||
dplyr::rename(es_code = output) %>%
|
||||
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")
|
||||
|
||||
|
||||
ess <- unique(newOP$es_code)
|
||||
es_impacted <- thisNet$nodes %>%
|
||||
dplyr::filter(code %in% ess) %>%
|
||||
dplyr::left_join(thisNet$edges, by=c("code"="input")) %>%
|
||||
dplyr::rename(es_code=code) %>%
|
||||
dplyr::left_join(thisNet$edges, by = c("code" = "input")) %>%
|
||||
dplyr::rename(es_code = code) %>%
|
||||
tidyr::drop_na() %>%
|
||||
dplyr::select(layer, output, es_code, values) %>%
|
||||
dplyr::rename(lo_code=output) %>%
|
||||
tidyr::nest(data=c(lo_code, values))
|
||||
dplyr::rename(lo_code = output) %>%
|
||||
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)
|
||||
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")
|
||||
|
||||
return(thisNet)
|
||||
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user