From 882f4cfb69b6e80021f394bf0ea6154a71a7663d Mon Sep 17 00:00:00 2001 From: Craig Williams Date: Thu, 7 Apr 2022 09:24:38 +0100 Subject: [PATCH 1/3] StyleR run --- Parses.R | 142 ++++++------ app.R | 646 +++++++++++++++++++++++++++-------------------------- extract.R | 92 ++++---- reWeight.R | 119 +++++----- 4 files changed, 507 insertions(+), 492 deletions(-) diff --git a/Parses.R b/Parses.R index dd8172c..8516969 100644 --- a/Parses.R +++ b/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,19 +85,18 @@ getInitial <- function(string, letter) { } split <- function(cell) { - params <- unlist(strsplit(cell, ",")) values <- rep(0, length(states)) for (n in 1:length(params)) { - kvp <- unlist(strsplit(params[n], "=")) - ref <- match(getInitial(trimws(kvp[1])), getInitial(states)) + kvp <- unlist(strsplit(params[n], "=")) + ref <- match(getInitial(trimws(kvp[1])), getInitial(states)) - if ((ref > 0) & (ref <= length(values))) { - values[ref] <- kvp[2] - } else { - print(paste("Unrecognised parameter(s):",params[n])) - } + if ((ref > 0) & (ref <= length(values))) { + values[ref] <- kvp[2] + } else { + print(paste("Unrecognised parameter(s):", params[n])) + } } return(values) @@ -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) 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:") diff --git a/app.R b/app.R index eac8ce0..ca4bbb3 100644 --- a/app.R +++ b/app.R @@ -31,198 +31,203 @@ impLabels <- c("Very High", "High", "Medium", "Low", "Very Low") ui <- dashboardPage( - - dashboardHeader(title = "JNCC MESO online", - tags$li( - id = "dropdownHelp", - class = "dropdown", - tags$head( - tags$script( - paste0( - "$(document).ready(function(){", - " $('#dropdownHelp')", - " .find('ul')", - " .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" - ) - ) - ) + dashboardHeader( + title = "JNCC MESO online", + tags$li( + id = "dropdownHelp", + class = "dropdown", + tags$head( + tags$script( + paste0( + "$(document).ready(function(){", + " $('#dropdownHelp')", + " .find('ul')", + " .click(function(e) { e.stopPropagation(); });", + "});" ) ) ), - 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") - ) + tags$a( + href = "javascript:void(0);", + class = "dropdown-toggle", + `data-toggle` = "dropdown", + icon("question") ), - 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" + 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" ) - ), - 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") - ) - ) + ) + ), + 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( + 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 Constants + # SERVER Constants print("Loading 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 @@ -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,19 +461,18 @@ 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), { isolate(myList <- reactiveValuesToList(input)) - matches <- match(pressures$code, names(myList)) + matches <- match(pressures$code, names(myList)) if (length(matches) > 0) { status <- NULL @@ -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,35 +527,34 @@ server <- function(input, output, session) { observeEvent(input$bbnDisplayEdges, { .selections$bbnEdges <- input$bbnDisplayEdges - }) observeEvent(input$layer1Slider, { showModal( - 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("l1PressSD", "Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01) - ) - }, - title = "Layer 1 controls", - footer = tagList( - modalButton("Cancel"), - actionButton("modalOK", "OK") - ), - size = "s") + 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("l1PressSD", "Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01) + ) + }, + title = "Layer 1 controls", + footer = tagList( + modalButton("Cancel"), + actionButton("modalOK", "OK") + ), + 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() ) ) @@ -826,13 +840,13 @@ server <- function(input, output, session) { settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE), 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) - #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) diff --git a/extract.R b/extract.R index 7515eeb..3db2a1f 100644 --- a/extract.R +++ b/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") + dplyr::select(hab, nodeType, Suggestion, node, newname) + save(newNameMap, file = "nameMap.RData") } - - - diff --git a/reWeight.R b/reWeight.R index 78c85ed..7ea8014 100644 --- a/reWeight.R +++ b/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, - 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])) + 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::select(presscode, layer, ba_code, values) %>% - tidyr::nest(data=c(presscode, values)) + dplyr::rename(presscode = code) %>% + dplyr::rename(ba_code = output) %>% + dplyr::select(presscode, layer, ba_code, 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::select(layer, output, ba_code, values) %>% - dplyr::rename(op_code=output) %>% - tidyr::nest(data=c(ba_code, values)) + dplyr::rename(ba_code = code) %>% + dplyr::select(layer, output, 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::select(layer, output, 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::select(layer, output, es_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) - } From 9739770393c182e9758fa744f624e1d2dbb4fa43 Mon Sep 17 00:00:00 2001 From: Craig Williams Date: Thu, 7 Apr 2022 09:38:11 +0100 Subject: [PATCH 2/3] Strip comments, save files and whitespace blocks --- Parses.R | 25 +++------------------ app.R | 66 ++++++++------------------------------------------------ 2 files changed, 12 insertions(+), 79 deletions(-) diff --git a/Parses.R b/Parses.R index 8516969..8663e59 100644 --- a/Parses.R +++ b/Parses.R @@ -117,7 +117,6 @@ getOutNodes <- function(codes, codeList) { } buildGraph <- function(model, desc) { - # model contains the following # node table, edge table @@ -125,7 +124,6 @@ buildGraph <- function(model, desc) { # 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 = "") @@ -153,13 +151,7 @@ buildGraph <- function(model, desc) { print("Saving model prior to network modelling") modelDefn <- paste0(inputText, edges) - save(modelDefn, file = "buildGraph.RData") - - - # print("about to build network") - # print(paste0(inputText, edges)) - - + # save(modelDefn, file = "buildGraph.RData") net <- model2network(paste0(inputText, edges), debug = FALSE) @@ -175,15 +167,12 @@ buildGraph <- function(model, desc) { allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes))) - # print(allDists) cfit <- custom.fit(net, allDists) cat("about to calculate sample distributions") - # print(outNodes) sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw") summDists <- summary(sampleDists) - # stdDev <- sd(sampleDists) print("sample distribution build successful") @@ -204,7 +193,6 @@ buildGraph <- function(model, desc) { getValidNodes <- function(mapping, prevOutputs, prefix) { - # Find row id for input nodes, internal and published inputNodes <- mapping[2:nrow(mapping), 1] @@ -271,10 +259,6 @@ getCode <- function(name, nodeDF) { } getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) { - # utils::str(nodeDF) - - # 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)) @@ -297,6 +281,7 @@ getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) { # if (count == 0) print(paste("No edges found for output", colnames(mapping)[col])) } } + if (is.null(prevEdge)) { return(data.frame( input = edgeM[, "inputNode"], @@ -321,8 +306,6 @@ parseMapping <- function(mapping, prevOutputs, prefix) { nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix) edgeDF <- getValidEdges(mapping, nodeDF, prevEdge = prevOutputs$edges, prefix) - # save(nodeDF, edgeDF, file="mapping.RData") - return(list( # New structure nodes = nodeDF, @@ -331,8 +314,6 @@ parseMapping <- function(mapping, prevOutputs, prefix) { } parseSheet <- function(fName) { - # get sheet names - print(paste("starting sheet load", fName)) if (file.exists(fName)) { @@ -342,7 +323,7 @@ parseSheet <- function(fName) { sheets <- sort(delNA(match(names, mappings))) cat("starting sheet parse") - # print(sheets) + print(sheets) if (sum(sheets == refs) == length(refs)) { # read all mapping tables diff --git a/app.R b/app.R index ca4bbb3..9b56dba 100644 --- a/app.R +++ b/app.R @@ -8,7 +8,6 @@ modules::import(shinyBS) modules::import(bnlearn) modules::import(visNetwork) modules::import(RColorBrewer) -modules::import(plotly) modules::import(openxlsx) modules::import(zip) modules::import(DT) @@ -16,7 +15,6 @@ modules::import(plyr) modules::import(magrittr) parser <- modules::use("Parses.R") - rw <- modules::use("reWeight.R") @@ -173,11 +171,11 @@ ui <- dashboardPage( p("Download results as Excel workbook") ) ), - plotlyOutput("layer1", height = "270px") %>% withSpinner(), + plotly::plotlyOutput("layer1", height = "270px") %>% withSpinner(), h4("Effect on Ecosystem Processes"), - plotlyOutput("layer2", height = "270px") %>% withSpinner(), + plotly::plotlyOutput("layer2", height = "270px") %>% withSpinner(), h4("Effect on Ecosystem Services"), - plotlyOutput("layer3", height = "270px") %>% withSpinner() + plotly::plotlyOutput("layer3", height = "270px") %>% withSpinner() ), tabItem( tabName = "3", h2("Bayesian Network"), @@ -229,7 +227,6 @@ server <- function(input, output, session) { palette <- c("firebrick", "coral", "rosybrown", "tan", "salmon", "olivedrab", "seagreen", "aquamarine", "darkcyan", "dodgerblue", "steelblue", "royalblue") - models <- NULL pressures <- NULL @@ -302,9 +299,6 @@ server <- function(input, output, session) { } setNewNames <- function(wb, habName) { - - # habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5)) - print(habName) possNames <- newNameMap %>% dplyr::filter(hab == habName) %>% @@ -334,7 +328,6 @@ server <- function(input, output, session) { print(paste("attempting to load", paste0(dataStorage, fileList[idx]))) wb <- parser$parseSheet(paste0(dataStorage, fileList[idx])) - # print(tmp) wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact) @@ -349,11 +342,9 @@ 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(modelList, file="models.RData") updateSelectInput(session, "modelSelect", choices = models) return(modelList) } @@ -361,11 +352,6 @@ 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") - - # 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) @@ -393,22 +379,12 @@ server <- function(input, output, session) { print(names(thisModel)) # 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") - - - if (sum(pressStatus$status == "On") > 0) { thisModel$p_es <- rw$reWeightModel(thisModel$p_es, pressStatus) } # else nothing to do - # save(pressStatus, thisModel, file="afterWeight.RData") - thisNet <- parser$buildGraph(thisModel$p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es"))) sampleDists <- cpdist( @@ -467,7 +443,6 @@ server <- function(input, output, session) { observeEvent(input$modelSelect, { .selections$model <<- match(input$modelSelect, models) - # .selections$runOnce <<- TRUE }) observeEvent(reactiveValuesToList(input), { @@ -510,7 +485,6 @@ server <- function(input, output, session) { ) # This assumes all pressures are the same... - setPressures(pressures) btnList <- apply(pressures, 1, makeRadioButtons) } @@ -634,8 +608,6 @@ server <- function(input, output, session) { nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c("On")]), ] - # save(nodes, edges, nodeNet, file = "tmp.RData") - if (nrow(nodeNet) > 0) { # do pressures edgeNet <- edges[edges$from %in% nodeNet$id, ] @@ -677,36 +649,22 @@ server <- function(input, output, session) { makeBbnGraph(modelList[[.selections$model]]) }) - # observe({ - # visNetworkProxy("bbnGraphPlot") %>% - # visStabilize(iterations = 10) - # }) - getModelName <- function() { paste0("data/", input$modelSelect, ".xlsx") } genPlot <- function(boxPlot, title, paletteLength) { if (nrow(boxPlot) > 0) { - - # print(paste('Palette length', paletteLength)) - - # palette <- brewer.pal(paletteLength, "Set3") - - # palette <- c("red", "sienna3", "plum2", "rosybrown4", "sandybrown", "yellow", "seashell3", "palegreen", "springgreen4", "steelblue", "azure") - names(palette) <- 1:length(palette) - # 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) + + plotly::plot_ly(boxPlot, x = boxPlot[, 1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>% + plotly::layout(xaxis = xform, yaxis = list(dtick = 0.25, range = c(-1.25, 1.25)), showlegend = FALSE, title = title) } } @@ -722,15 +680,15 @@ server <- function(input, output, session) { } } - output$layer1 <- renderPlotly({ + output$layer1 <- plotly::renderPlotly({ prepPlot("ba", "Functional Groups") }) - output$layer2 <- renderPlotly({ + output$layer2 <- plotly::renderPlotly({ prepPlot("op", "Ecosystem Processes") }) - output$layer3 <- renderPlotly({ + output$layer3 <- plotly::renderPlotly({ prepPlot("es", "Ecosystem Services") }) @@ -831,8 +789,6 @@ server <- function(input, output, session) { dir.create(tmp) setwd(tmp) - - l <- list( pressures = .selections$pressStatus, nodes = modelList[[.selections$model]]$p_es$nodes, @@ -842,12 +798,8 @@ server <- function(input, output, session) { ) xl <- write.xlsx(l, "dataset.xlsx") - # zipFile <- zipr(file, c("dataset.xlsx")) - file.copy("dataset.xlsx", file) - # print(paste("zip file complete", zipFile)) - setwd(oldDir) unlink(tmp) From 99fa481fcbbc3dda3f2c462d9bd67f52f11fb12c Mon Sep 17 00:00:00 2001 From: Craig Williams Date: Thu, 7 Apr 2022 10:06:30 +0100 Subject: [PATCH 3/3] FRemoved a bunch of prints, str's and cats --- Parses.R | 8 +++++--- app.R | 9 ++------- extract.R | 10 +++++----- reWeight.R | 22 ++++++---------------- 4 files changed, 18 insertions(+), 31 deletions(-) diff --git a/Parses.R b/Parses.R index 8663e59..0b24977 100644 --- a/Parses.R +++ b/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) diff --git a/app.R b/app.R index 9b56dba..de028c1 100644 --- a/app.R +++ b/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, diff --git a/extract.R b/extract.R index 3db2a1f..1f41d6c 100644 --- a/extract.R +++ b/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") } diff --git a/reWeight.R b/reWeight.R index 7ea8014..84a1f11 100644 --- a/reWeight.R +++ b/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)