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

10
Parses.R
View File

@@ -85,7 +85,6 @@ getInitial <- function(string, letter) {
}
split <- function(cell) {
params <- unlist(strsplit(cell, ","))
values <- rep(0, length(states))
@@ -284,10 +283,11 @@ getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
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)]
)
@@ -339,7 +339,6 @@ parseSheet <- function(fName) {
names <- openxlsx::getSheetNames(fName)
if (length(names) > 0) {
sheets <- sort(delNA(match(names, mappings)))
cat("starting sheet parse")
@@ -360,7 +359,6 @@ parseSheet <- function(fName) {
legend = legend
)
)
} else {
print(paste("Sheets found include", mappings[sheets]))
cat("Missing sheets are:")

116
app.R
View File

@@ -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,7 +80,8 @@ 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")),
@@ -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(
@@ -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)
}
@@ -277,7 +292,8 @@ server <- function(input, output, session) {
# 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("\\)", "") %>%
@@ -323,7 +339,6 @@ server <- function(input, output, session) {
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)) %>%
stringr::str_replace_all("_", " ")
print(habName)
@@ -346,15 +361,13 @@ server <- function(input, output, session) {
# 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"))
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"]
@@ -438,7 +451,6 @@ server <- function(input, output, session) {
stringsAsFactors = FALSE
))
} else {
return(data.frame(
name = thisModel$p_es$nodes$name,
code = thisModel$p_es$nodes$code,
@@ -449,7 +461,6 @@ server <- function(input, output, session) {
maxes = apply(sampleDists, 2, max),
stringsAsFactors = FALSE
))
}
}
@@ -478,7 +489,6 @@ server <- function(input, output, session) {
.selections$pressStatus <<- newStatus
}
}
})
@@ -517,13 +527,13 @@ 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),
@@ -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()
})
@@ -643,7 +651,6 @@ server <- function(input, output, session) {
if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break
nodeNet <- rbind(nodeNet, nodesToAdd)
edgeNet <- rbind(edgeNet, edgesToAdd)
} # until finished
} else {
edgeNet <- edges
@@ -692,13 +699,14 @@ server <- function(input, output, session) {
# print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
# cat(colours)
xform <- list(categoryorder = "array",
xform <- list(
categoryorder = "array",
categoryarray = boxPlot[, 1],
zerolinewidth = 10)
zerolinewidth = 10
)
#
plot_ly(boxPlot, x = boxPlot[, 1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
layout(xaxis = xform, yaxis = list(dtick = 0.25, range = c(-1.25, 1.25)), showlegend = FALSE, title = title)
}
}
@@ -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,16 +760,19 @@ 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
)
@@ -780,7 +795,6 @@ server <- function(input, output, session) {
max = likeliTab$range[elementRow + 6]
)
outputTab <- rbind(outputTab, tabRow)
}
likelihoods <- data.frame(
@@ -798,10 +812,10 @@ server <- function(input, output, session) {
}
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(
@@ -841,8 +855,6 @@ server <- function(input, output, session) {
},
contentType = "application/xlsx"
)
}
shinyApp(ui, server)

16
extract.R
View File

@@ -5,12 +5,16 @@ fList <- list.files("data", pattern="*.xlsx")
# 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()
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) {
@@ -32,7 +36,9 @@ getNodeVals <- function(nodeStr) {
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()
@@ -98,7 +104,6 @@ for (wbIdx in 1:length(fList)) {
res
)
)
}
mapNewNames <- function() {
@@ -106,6 +111,3 @@ mapNewNames <- function() {
dplyr::select(hab, nodeType, Suggestion, node, newname)
save(newNameMap, file = "nameMap.RData")
}

23
reWeight.R
View File

@@ -1,7 +1,6 @@
modules::import(magrittr)
reWeightLayer <- function(nestedLayerTib, fudge = 1) {
for (idx in 1:nrow(nestedLayerTib)) {
# print(nestedLayerTib$data[idx])
thisData <- nestedLayerTib$data[idx][[1]]
@@ -12,16 +11,22 @@ reWeightLayer <- function(nestedLayerTib, fudge=1) {
survived <- 1
grown <- 1
for (depIdx in 1:nrow(thisData)) {
if (thisData$values[depIdx]<0) survived <- survived * (1 + thisData$values[depIdx]) else
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
effDepRate <- survived - 1
effGrowthRate <- 1 - grown
# print(effDepRate)
if (sum(thisData$values)==0) newValues <- rep(0, length(thisData$values)) else
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
}
@@ -29,14 +34,15 @@ reWeightLayer <- function(nestedLayerTib, fudge=1) {
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)
@@ -44,13 +50,11 @@ assignWeights <- function(
print(paste(ref, edgesTib$values[ref], value[idx]))
edgesTib$values[ref] <- value[idx]
# 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?
@@ -128,5 +132,4 @@ reWeightModel <- function(thisNet, pressStatus) {
print("exitting reweighting process")
return(thisNet)
}