How to efficiently address circular dependencies between matrixes in R?
I come to R from XLS where I'm used to addressing this sort of "circular reference" problem. I wonder if there's a clean, efficient way to handle this sort of issue in R.
The image below best explains my question. The original code at the bottom generates 3 matrixes, which are then embedded in lists. Data currently flows sequentially "downstream" from one matrix to another. For example, $Series_One$Reserve$Out flows to $Series_One$Class_A_current$In, and $Series_One$Class_A_current$Out flows to $Series_One$Class_A_prior_unpd$In. The flow is sequentially downward. But now I'm trying to figure how to send data "upstream"; I would like to send the values in column $Series_One$Class_A_prior_unpd$Post_FC_short "upstream" to $Series_One$Reserve$Due_Class_A as shown in the upward pointing arrow in the image below. As noted, the values currently in $Series_One$Reserve$Due_Class_A are only placeholders. The image below is a nice depiction of the classic circular reference problem. I also post an image for the SHORT CODE example.
In R, how are these types of mutual, circular dependencies best resolved?
How I would solve this manually is (in referencing the original code below) to first set all $Series_One$Reserve$Due_Class_A cells to zeroes, see what the resulting values are in $Series_One$Class_A_prior_unpd$Post_FC_short, and then manually plop those "pro forma" $Series_One$Class_A_prior_unpd$Post_FC_short values back into $Series_One$Reserve$Due_Class_A. But my mind keeps flashing "circular reference" after years of XLS use.
Apologies for the long original code (I edited this post with SHORT CODE example that also illustrates the same circular reference issue).
Short Code:
masterList <- list(
list1 = data.frame(
Inflow = c(10,15,12),
Cover_list1 = c(4,5,2),
Cover_list2 = c(0,0,0)
),
list2 = data.frame(
Cover_list2 = c(4,2,6),
Draw_list1 = c(0,0,0)
)
)
circRef <- function(x) {
output <- x
for (i in seq_along(x)) {
sublist <- x[[i]]
if (i == 2) {
sublist <- cbind(Inflow = output[[1]]$Outflow, sublist)
sublist$Outflow <- sublist$Inflow - sublist$Cover_list2 + sublist$Draw_list1
}
else {
sublist$Outflow <- sublist$Inflow - rowSums(as.matrix(sublist[, -(1)]))
}
output[[i]] <- sublist
}
return(output)
}
circRef(masterList)
Original Code:
fallFCSeries <- list(Series_One = c('Reserve','Class_A_current','Class_A_prior_unpd'))
CF <- c(6, 5, 600)
balance <- c(1000,1100,1200)
resAcct <- list(Series_One = list(Target = 0.02,Classes = c('A')))
fallFC <- function(nbr_rows) {
bucket <- vector('list', length = 1)
series_elements <- fallFCSeries[["Series_One"]]
mat_list <- vector('list', length = 3)
for (j in seq_along(series_elements)) {
element <- series_elements[j]
mat <- matrix(0, nbr_rows,
if (element == "Reserve") {7} else {
if(grepl("unpd",element)){7} else {5}
}
)
if (element == "Reserve") {
colnames(mat) <- c('In','Target','Top','Due_Class_A','Draw_Class_A','End_bal','Out')
} else {
if(!grepl("unpd",element)){
colnames(mat) <- c('In','Due','FC_cover','Post_FC_short','Out')
} else{
colnames(mat) <- c('In','Due','FC_cover','Post_FC_short','RA_cover','Post_RA_short','Out')
}
}
for (k in 1:nbr_rows) {
Bal <- balance[k]
seriesCF <- CF[k]
if (j == 1) {
mat[k, "In"] <- seriesCF} else {mat[k,"In"] <- bucket[[1]][[j - 1]][k, "Out"]}
if (element == "Reserve") {
mat[k,"Target"] <- round(Bal * resAcct[["Series_One"]]$Target,2)
mat[k,"Top"] <- min(mat[k,"In"], (max(0, mat[k, "Target"])))
mat[k,"Out"] <- mat[k,"In"]
cumTops <- sum(mat[1:k,"Top"])
due_val <- round(runif(1, min = 0, max = mat[k,"Target"]),2) # this is placeholder!!
mat[k, paste0("Due_Class_", "A")] <- due_val
cum_draws_lag <- if(k == 1){0} else {sum(mat[1:k-1, grepl("^Draw", colnames(mat))])}
sumDraws <- sum(mat[k,1:5][grepl("^Draw", colnames(mat)[1:5])])
draw <- min(due_val,cumTops - cum_draws_lag - sumDraws)
mat[k, "Draw_Class_A"] <- draw
cumDraws <- sum(mat[1:k,grepl("^Draw", colnames(mat))])
mat[k, "End_bal"] <- cumTops - cumDraws
mat[k,"Out"] <- mat[k,"In"] - mat[k,"Top"]
}
else{ # if element <> "Reserve"...
if(grepl("unpd",element)){
extractClass <- sub("_prior.*", "", element)
pattern <- paste0(extractClass,".*current")
match_element <- which(grepl(pattern, names(bucket[[1]])))
}
mat[k, "Due"] <- if(!grepl("unpd", element)){
round(Bal * 0.50,2)
} else {sum(bucket[[1]][[match_element]][1:k,"Post_FC_short"])}
mat[k, "FC_cover"] <- min(mat[k, "In"], mat[k, "Due"])
mat[k, "Post_FC_short"] <- mat[k, "Due"] - mat[k, "FC_cover"]
if(grepl("unpd",element)){
mat[k, "RA_cover"] <- 0
mat[k, "Post_RA_short"] <- 0
}
mat[k, "Out"] <- mat[k, "In"] - mat[k, "FC_cover"]
}
}
mat_list[[j]] <- mat
names(mat_list) <- series_elements
bucket[[1]] <- setNames(mat_list, series_elements)
}
names(bucket) <- "Series_One"
return(bucket)
}
fallFC(3)
Below are solutions for the short code and original code examples, following what I say in the OP with "How I would solve this manually is..." and user2554330 suggestion to solve it with a loop. I'm open to any cleaner solutions, R has amazing tricks the deeper you dig.
Short code solution (note my comments # ADDED):
circRef <- function(x) {
output <- x
for (i in 1:2) { # ADDED
for (j in seq_along(x)) {
sublist <- x[[j]]
if (j == 2) {
sublist <- cbind(Inflow = output[[1]]$Outflow, sublist)
if(i == 2){sublist$Draw_list1 <- stored_values} # ADDED
sublist$Outflow <- sublist$Inflow - sublist$Cover_list2 + sublist$Draw_list1
}
else {
if(i == 2){sublist$Cover_list2 <- stored_values} # ADDED
sublist$Outflow <- sublist$Inflow - rowSums(as.matrix(sublist[, -(1)]))
}
output[[j]] <- sublist
if(i==1){stored_values <<- (sublist$Inflow - sublist$Cover_list2) * 0.50} # ADDED
}
}
return(output)
}
circRef(masterList)
Original code solution:
fallFC <- function(nbr_rows) {
bucket <- vector('list', length = 1)
series_elements <- fallFCSeries[["Series_One"]]
mat_list <- vector('list', length = 3)
# iterate twice: first time without reserve due amounts; second time with prior_unpd Pst_FC_short amounts
for (iter in 1:2) { # ADDED
for (j in seq_along(series_elements)) {
element <- series_elements[j]
mat <- matrix(0, nbr_rows,
if (element == "Reserve") {7} else {
if(grepl("unpd",element)){7} else {5}
}
)
if (element == "Reserve") {
colnames(mat) <- c('In','Target','Top','Due_Class_A','Draw_Class_A','End_bal','Out')
} else {
if(!grepl("unpd",element)){
colnames(mat) <- c('In','Due','FC_cover','Post_FC_short','Out')
} else{
colnames(mat) <- c('In','Due','FC_cover','Post_FC_short','RA_cover','Post_RA_short','Out')
}
}
for (k in 1:nbr_rows) {
Bal <- balance[k]
seriesCF <- CF[k]
if (j == 1) {
mat[k, "In"] <- seriesCF} else {mat[k,"In"] <- bucket[[1]][[j - 1]][k, "Out"]}
if (element == "Reserve") {
mat[k,"Target"] <- round(Bal * resAcct[["Series_One"]]$Target,2)
mat[k,"Top"] <- min(mat[k,"In"], (max(0, mat[k, "Target"])))
mat[k,"Out"] <- mat[k,"In"]
cumTops <- sum(mat[1:k,"Top"])
# ADDED: set all values to 0 in the first iteration
due_val <- if (iter == 1) {0} else {stored_values[k]}
mat[k, paste0("Due_Class_", "A")] <- due_val
cum_draws_lag <- if(k == 1){0} else {sum(mat[1:k-1, grepl("^Draw", colnames(mat))])}
sumDraws <- sum(mat[k,1:5][grepl("^Draw", colnames(mat)[1:5])])
draw <- min(due_val,cumTops - cum_draws_lag - sumDraws)
mat[k, "Draw_Class_A"] <- draw
cumDraws <- sum(mat[1:k,grepl("^Draw", colnames(mat))])
mat[k, "End_bal"] <- cumTops - cumDraws
mat[k,"Out"] <- mat[k,"In"] - mat[k,"Top"]
}
else{ # if element <> "Reserve"...
if(grepl("unpd",element)){
extractClass <- sub("_prior.*", "", element)
pattern <- paste0(extractClass,".*current")
match_element <- which(grepl(pattern, names(bucket[[1]])))
}
mat[k, "Due"] <- if(!grepl("unpd", element)){
round(Bal * 0.50,2)
} else {sum(bucket[[1]][[match_element]][1:k,"Post_FC_short"])}
mat[k, "FC_cover"] <- min(mat[k, "In"], mat[k, "Due"])
mat[k, "Post_FC_short"] <- mat[k, "Due"] - mat[k, "FC_cover"]
if(grepl("unpd",element)){
mat[k, "RA_cover"] <- draw
mat[k, "Post_RA_short"] <- mat[k,"Post_FC_short"] - mat[k,"RA_cover"]
}
mat[k, "Out"] <- mat[k, "In"] - mat[k, "FC_cover"]
}
}
mat_list[[j]] <- mat
names(mat_list) <- series_elements
bucket[[1]] <- setNames(mat_list, series_elements)
}
names(bucket) <- "Series_One"
stored_values <- bucket[[1]][["Class_A_prior_unpd"]][, "Post_FC_short"] # ADDED
} # close iteration ADDED
return(bucket)
}
fallFC(3)
- Floating point less-than-equal comparisons after addition and subtraction
- ggplot fill spilling over shape when used with different geoms
- Compute mutual gaze from individual gazes
- Inverse of gamma function with R
- Conditionally mutating 2 dataframes
- Easiest way to save an S4 class
- Updating values of three dot ellipsis in R
- How to make a multifactor model in pROC?
- Using hidden API to scrape website with JavaScript pager
- Map colours not showing correctly, all SpatRaster values converted to 1 when using crop and mask
- Hierarchical Bayes for R or Python
- How to insert the "Copy to clipboard" icon in an r markdown document
- Name new variables with purrr::map()
- Show every time stamp in plotly x-axis
- Represent the selectInput value in an infoBox
- Display the selectInput value in a R shiny widget box
- SelectInput Value update based on previous SelectInput in R shiny
- Using Conditional Panel with PickerInput in R
- Display multiple infoboxes within one reactive function
- R shiny sever problems - reactive global environment
- Show / Hide selectinput in R shiny based on conditions
- Update data from selectInput
- Usage of UIOutput in multiple menuItems
- Automating the slider of SelectInput
- ggplot - geom_point: setting manual fill color for point jitter without changing boxplot fill color
- why does assigning to the ellipsis `... <- 1` not throw an error?
- checkboxGroupInput delete table output in a shiny app
- ShinyApp: How to pass plot from one module into another one in order to download it in a report?
- Names of a numeric vector with HTML
- How to place elements above the dashboardHeader