StyleR run
This commit is contained in:
119
reWeight.R
119
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)
|
||||
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user