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 #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 } #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=","))) nestedLayerTib$data[idx][[1]]$values <- newValues / fudge } return(nestedLayerTib %>% tidyr::unnest(cols=c(data))) } 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) } reWeightModel <- function(thisNet, pressStatus) { print("About to recalc p - 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) 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)) newP <- reWeightLayer(p_on, fudge=1) print("About to recalc ba - 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")) %>% 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)) newBA <- reWeightLayer(ba_impacted, fudge=4) print("About to recalc op - 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) %>% tidyr::drop_na() %>% dplyr::select(layer, output, op_code, values) %>% dplyr::rename(es_code=output) %>% tidyr::nest(data=c(op_code, values)) newOP <- reWeightLayer(op_impacted, fudge=4) #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) %>% tidyr::drop_na() %>% dplyr::select(layer, output, es_code, values) %>% dplyr::rename(lo_code=output) %>% tidyr::nest(data=c(lo_code, values)) newES <- reWeightLayer(es_impacted, fudge=2) 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) value <- c(newP$values, newBA$values, newOP$values, newES$values) thisNet$edges <- assignWeights(thisNet$edges, incode, outcode, value) print("exitting reweighting process") return(thisNet) }