FRemoved a bunch of prints, str's and cats
This commit is contained in:
8
Parses.R
8
Parses.R
@@ -57,10 +57,13 @@ parseScenario <- function(press, prefix = "p") {
|
||||
ncol = 3,
|
||||
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)]
|
||||
}
|
||||
|
||||
press[is.na(press)] <- 0
|
||||
|
||||
if (sum(duplicated(pressNames)) > 0) {
|
||||
cat("Duplicated pressure node names found")
|
||||
print(pressNodes[duplicated(pressNames)])
|
||||
@@ -145,13 +148,12 @@ buildGraph <- function(model, desc) {
|
||||
c(model$nodes$growth[nodeRef], model$edges$values[rows]),
|
||||
c("(Intercept)", model$edges$input[rows])
|
||||
)
|
||||
# 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")
|
||||
|
||||
net <- model2network(paste0(inputText, edges), debug = FALSE)
|
||||
|
||||
@@ -169,7 +171,7 @@ buildGraph <- function(model, desc) {
|
||||
|
||||
cfit <- custom.fit(net, allDists)
|
||||
|
||||
cat("about to calculate sample distributions")
|
||||
print("about to calculate sample distributions")
|
||||
|
||||
sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw")
|
||||
summDists <- summary(sampleDists)
|
||||
|
||||
9
app.R
9
app.R
@@ -299,21 +299,18 @@ server <- function(input, output, session) {
|
||||
}
|
||||
|
||||
setNewNames <- function(wb, habName) {
|
||||
print(habName)
|
||||
possNames <- newNameMap %>%
|
||||
dplyr::filter(hab == habName) %>%
|
||||
dplyr::mutate(node = stripStr(node))
|
||||
|
||||
newNodes <- wb$p_es$nodes %>% dplyr::mutate(node = stripStr(name))
|
||||
|
||||
print(possNames$node)
|
||||
print(newNodes$node)
|
||||
newNames <- apply(newNodes, 1, function(row) {
|
||||
id <- match(row["node"], possNames$node)
|
||||
print(paste(id, row["node"]))
|
||||
possNames$newname[id]
|
||||
})
|
||||
print(newNames)
|
||||
|
||||
wb$p_es$nodes$name <- newNames
|
||||
return(wb)
|
||||
}
|
||||
@@ -334,7 +331,6 @@ server <- function(input, output, session) {
|
||||
if (!is.null(wb)) {
|
||||
habName <- substr(fileList[idx], 1, (nchar(fileList[idx]) - 5)) %>%
|
||||
stringr::str_replace_all("_", " ")
|
||||
print(habName)
|
||||
|
||||
wb2 <- setNewNames(wb, habName)
|
||||
|
||||
@@ -345,6 +341,7 @@ server <- function(input, output, session) {
|
||||
cnt <- cnt + 1
|
||||
}
|
||||
}
|
||||
|
||||
updateSelectInput(session, "modelSelect", choices = models)
|
||||
return(modelList)
|
||||
}
|
||||
@@ -628,8 +625,6 @@ server <- function(input, output, session) {
|
||||
edgeNet <- edges
|
||||
}
|
||||
|
||||
print(paste(nrow(model$legend), length(palette)))
|
||||
|
||||
legendDF <- data.frame(
|
||||
id = 1:nrow(model$legend),
|
||||
label = model$legend,
|
||||
|
||||
10
extract.R
10
extract.R
@@ -1,5 +1,6 @@
|
||||
# R script to upload the existing spreadsheets and homologise them
|
||||
library(magrittr)
|
||||
modules::import(magrittr)
|
||||
|
||||
fList <- list.files("data", pattern = "*.xlsx")
|
||||
|
||||
# Objective to create data tables with
|
||||
@@ -46,7 +47,7 @@ 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
|
||||
|
||||
|
||||
# Drop the time column no use at all....
|
||||
sheet <- openxlsx::readWorkbook(wb, sheet = sheetNames[1])[, -1]
|
||||
@@ -73,6 +74,7 @@ for (wbIdx in 1:length(fList)) {
|
||||
|
||||
# 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)])
|
||||
@@ -82,6 +84,7 @@ for (wbIdx in 1:length(fList)) {
|
||||
|
||||
# linkCheck("outputprocesses", op, op_check)
|
||||
|
||||
|
||||
legend <- openxlsx::readWorkbook(wb, sheet = sheetNames[5])
|
||||
|
||||
nodeType <- c(
|
||||
@@ -91,8 +94,6 @@ for (wbIdx in 1:length(fList)) {
|
||||
rep("ecosystemservice", length(es))
|
||||
)
|
||||
|
||||
|
||||
|
||||
res <- t(sapply(es_nodes[1, ], getNodeVals)) %>% as.data.frame()
|
||||
names(res) <- cleanNames(names(res))
|
||||
res <- res %>% mutate(nodeName = names(res))
|
||||
@@ -109,5 +110,4 @@ for (wbIdx in 1:length(fList)) {
|
||||
mapNewNames <- function() {
|
||||
newNameMap <- openxlsx::read.xlsx("MBA_MESO_Nodes.xlsx") %>%
|
||||
dplyr::select(hab, nodeType, Suggestion, node, newname)
|
||||
save(newNameMap, file = "nameMap.RData")
|
||||
}
|
||||
|
||||
22
reWeight.R
22
reWeight.R
@@ -2,7 +2,6 @@ modules::import(magrittr)
|
||||
|
||||
reWeightLayer <- function(nestedLayerTib, fudge = 1) {
|
||||
for (idx in 1:nrow(nestedLayerTib)) {
|
||||
# print(nestedLayerTib$data[idx])
|
||||
thisData <- nestedLayerTib$data[idx][[1]]
|
||||
|
||||
# Calculate the overall depletion rate
|
||||
@@ -21,35 +20,28 @@ reWeightLayer <- function(nestedLayerTib, fudge = 1) {
|
||||
|
||||
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=",")))
|
||||
|
||||
nestedLayerTib$data[idx][[1]]$values <- newValues / fudge
|
||||
}
|
||||
|
||||
return(nestedLayerTib %>% tidyr::unnest(cols = c(data)))
|
||||
}
|
||||
|
||||
assignWeights <- function(edgesTib,
|
||||
incode,
|
||||
outcode,
|
||||
value) {
|
||||
assignWeights <- function(edgesTib, incode, outcode, value) {
|
||||
for (idx in 1:length(incode)) {
|
||||
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")
|
||||
print(paste(ref, edgesTib$values[ref], value[idx]))
|
||||
edgesTib$values[ref] <- value[idx]
|
||||
# Set the appropriate values
|
||||
}
|
||||
return(edgesTib)
|
||||
}
|
||||
@@ -64,9 +56,6 @@ reWeightModel <- function(thisNet, pressStatus) {
|
||||
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) %>%
|
||||
@@ -76,7 +65,6 @@ reWeightModel <- function(thisNet, pressStatus) {
|
||||
newP <- reWeightLayer(p_on, fudge = 1)
|
||||
|
||||
|
||||
|
||||
print("About to recalc ba - op")
|
||||
|
||||
# Repeat for the linkage between ba and op
|
||||
@@ -92,6 +80,7 @@ reWeightModel <- function(thisNet, pressStatus) {
|
||||
|
||||
newBA <- reWeightLayer(ba_impacted, fudge = 4)
|
||||
|
||||
|
||||
print("About to recalc op - es")
|
||||
|
||||
# Repeat for the linkage between op and es
|
||||
@@ -107,10 +96,10 @@ reWeightModel <- function(thisNet, pressStatus) {
|
||||
|
||||
newOP <- reWeightLayer(op_impacted, fudge = 2)
|
||||
|
||||
|
||||
# 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) %>%
|
||||
@@ -129,6 +118,7 @@ reWeightModel <- function(thisNet, pressStatus) {
|
||||
|
||||
thisNet$edges <- assignWeights(thisNet$edges, incode, outcode, value)
|
||||
|
||||
|
||||
print("exitting reweighting process")
|
||||
|
||||
return(thisNet)
|
||||
|
||||
Reference in New Issue
Block a user