Skip to content

Commit

Permalink
action_age: Rewrite with standard stock_ss() #74 #134
Browse files Browse the repository at this point in the history 
stock_ss() now has enough flexibility to replace action_age's custom
shenanigans, so rewrite with stock_ss()

Use "vec = age", rather than "vec = all", so we no longer have to have
age dimensions at the start.
  • Loading branch information
@lentinj
lentinj committed May 7, 2024
1 parent 60a618d commit ce05843
Show file tree
Hide file tree
Showing 3 changed files with 35 additions and 85 deletions.
96 changes: 23 additions & 73 deletions R/action_age.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,42 +8,6 @@ g3a_age <- function(
transition_at = g3_action_order$age ) {
out <- new.env(parent = emptyenv())

# Replace anything of form xxx[.[1,2,3]] with xxx[1,2,3]
fix_subsets <- function (in_f) {
call_replace(in_f, "[" = function (subset_call) {
if (!is.call(subset_call)) {
# Raw [ symbol, just return it
subset_call
} else if (length(subset_call) == 3 &&
is.call(subset_call[[3]]) &&
subset_call[[3]][[1]] == as.symbol("[") &&
subset_call[[3]][[2]] == quote(.)) {
# Call of form summat[.[1,2, .. ]], remove nesting
as.call(c(
head(as.list(subset_call), -1),
tail(as.list(subset_call[[3]]), -2)))
} else {
# Recurse through subsetting call
as.call(lapply(as.list(subset_call), fix_subsets))
}
})
}

# Convert list of subset args into an actual call
to_subset_call <- function (l) {
as.call(c(list(as.symbol("["), as.symbol(".")), unname(l)))
}

# Mangle stock_num / stock_wgt to remove non-age parameters
age_iter_ss <- to_subset_call(lapply(stock$iter_ss, function (x) {
if (as.character(x) %in% c("stock__age_idx")) x
else quote(x[,1])[[3]] # i.e. anything else should be missing
}))
age_younger_iter_ss <- to_subset_call(lapply(stock$iter_ss, function (x) {
if (as.character(x) %in% c("stock__age_idx")) call("-", x, 1L) # Subtract 1 to age paramter
else quote(x[,1])[[3]] # i.e. anything else should be missing
}))

stock__num <- g3_stock_instance(stock, 0)
stock__wgt <- g3_stock_instance(stock, 1)
stock_movement <- g3s_age(
Expand All @@ -53,11 +17,6 @@ g3a_age <- function(
stock_movement__transitioning_num <- g3_stock_instance(stock_movement)
stock_movement__transitioning_wgt <- g3_stock_instance(stock_movement)

movement_age_iter_ss <- to_subset_call(lapply(stock_movement$iter_ss, function (x) {
if (as.character(x) %in% c("stock__age_idx")) quote(g3_idx(1)) # stock_movement only has one age bracket
else quote(x[,1])[[3]] # i.e. anything else should be missing
}))

# Handle single-age special case separately
if (g3_stock_def(stock, 'maxage') == g3_stock_def(stock, 'minage')) {
if (length(output_stocks) == 0) {
Expand All @@ -66,21 +25,19 @@ g3a_age <- function(
}

# Instead of using the below, just move-and-zero stocks
out[[step_id(run_at, 1, stock)]] <- g3_step(fix_subsets(f_substitute(~if (run_f) {
out[[step_id(run_at, 1, stock)]] <- g3_step(f_substitute(~if (run_f) {
debug_label("g3a_age for ", stock)
stock_with(stock, stock_with(stock_movement, for (age in seq(stock__maxage, stock__minage, by = -1)) g3_with(
stock__age_idx := g3_idx(age - stock__minage + 1L), {
debug_trace("Move oldest ", stock, " into ", stock_movement)
# NB: We should be doing this once in a normal iterate case, but here there's only one loop so doesn't matter
# NB: This relies on the dimension ordering between stock_movement & stock matching
stock_movement__transitioning_num[movement_age_iter_ss] <- stock_reshape(stock_movement, stock__num[age_iter_ss])
stock_movement__transitioning_wgt[movement_age_iter_ss] <- stock_reshape(stock_movement, stock__wgt[age_iter_ss])
stock__num[age_iter_ss] <- 0
stock_ss(stock_movement__transitioning_num, age = g3_idx(1), vec = age) <- stock_reshape(stock_movement, stock_ss(stock__num, age = default, vec = age))
stock_ss(stock_movement__transitioning_wgt, age = g3_idx(1), vec = age) <- stock_reshape(stock_movement, stock_ss(stock__wgt, age = default, vec = age))
stock_ss(stock__num, age = default, vec = age) <- 0
})))
}, list(
run_f = run_f,
movement_age_iter_ss = movement_age_iter_ss,
age_iter_ss = age_iter_ss))))
run_f = run_f )))

# NB: move_remainder = FALSE because it's pointless here (and we can't move back into stock_movement)
out[[step_id(transition_at, 90, stock)]] <- g3a_step_transition(stock_movement, output_stocks, output_ratios, move_remainder = FALSE, run_f = run_f)
Expand All @@ -89,33 +46,28 @@ g3a_age <- function(

# Add transition steps if output_stocks provided
if (length(output_stocks) == 0) {
final_year_f = fix_subsets(f_substitute(~{
final_year_f <- ~{
debug_trace("Oldest ", stock, " is a plus-group, combine with younger individuals")
stock__wgt[age_iter_ss] <- ratio_add_vec(
stock__wgt[age_iter_ss], stock__num[age_iter_ss],
stock__wgt[age_younger_iter_ss], stock__num[age_younger_iter_ss])
stock__num[age_iter_ss] <- stock__num[age_iter_ss] + stock__num[age_younger_iter_ss]
}, list(
age_iter_ss = age_iter_ss,
age_younger_iter_ss = age_younger_iter_ss)))
stock_ss(stock__wgt, age = default, vec = age) <- ratio_add_vec(
stock_ss(stock__wgt, age = default, vec = age), stock_ss(stock__num, age = default, vec = age),
stock_ss(stock__wgt, age = default - 1, vec = age), stock_ss(stock__num, age = default - 1, vec = age))
stock_ss(stock__num, age = default, vec = age) <- stock_ss(stock__num, age = default, vec = age) + stock_ss(stock__num, age = default - 1, vec = age)
}
} else {
final_year_f = fix_subsets(f_substitute(~stock_with(stock_movement, {
final_year_f <- ~stock_with(stock_movement, {
debug_trace("Move oldest ", stock, " into ", stock_movement)
# NB: We should be doing this once in a normal iterate case, but here there's only one loop so doesn't matter
# NB: This relies on the dimension ordering between stock_movement & stock matching
stock_movement__transitioning_num[movement_age_iter_ss] <- stock_reshape(stock_movement, stock__num[age_iter_ss])
stock_movement__transitioning_wgt[movement_age_iter_ss] <- stock_reshape(stock_movement, stock__wgt[age_iter_ss])
stock__num[age_iter_ss] <- stock__num[age_younger_iter_ss]
stock__wgt[age_iter_ss] <- stock__wgt[age_younger_iter_ss]
}), list(
movement_age_iter_ss = movement_age_iter_ss,
age_iter_ss = age_iter_ss,
age_younger_iter_ss = age_younger_iter_ss)))
stock_ss(stock_movement__transitioning_num, age = g3_idx(1), vec = age) <- stock_reshape(stock_movement, stock_ss(stock__num, age = default, vec = age))
stock_ss(stock_movement__transitioning_wgt, age = g3_idx(1), vec = age) <- stock_reshape(stock_movement, stock_ss(stock__wgt, age = default, vec = age))
stock_ss(stock__num, age = default, vec = age) <- stock_ss(stock__num, age = default - 1, vec = age)
stock_ss(stock__wgt, age = default, vec = age) <- stock_ss(stock__wgt, age = default - 1, vec = age)
})
# NB: move_remainder = FALSE because it's pointless here (and we can't move back into stock_movement)
out[[step_id(transition_at, 90, stock)]] <- g3a_step_transition(stock_movement, output_stocks, output_ratios, move_remainder = FALSE, run_f = run_f)
}

out[[step_id(run_at, 1, stock)]] <- g3_step(fix_subsets(f_substitute(~if (run_f) {
out[[step_id(run_at, 1, stock)]] <- g3_step(f_substitute(~if (run_f) {
debug_label("g3a_age for ", stock)

stock_with(stock, for (age in seq(stock__maxage, stock__minage, by = -1)) g3_with(
Expand All @@ -126,19 +78,17 @@ g3a_age <- function(
final_year_f
} else if (age == stock__minage) {
debug_trace("Empty youngest ", stock, " age-group")
stock__num[age_iter_ss] <- 0
# NB: Leave stock__wgt[age_iter_ss] as-is, it's value is irrelevant with zero stock, and will result in NaN if we zero it.
stock_ss(stock__num, age = default, vec = age) <- 0
# NB: Leave stock__wgt[age] as-is, it's value is irrelevant with zero stock, and will result in NaN if we zero it.
} else {
debug_trace("Move ", stock, " age-group to next one up")
stock__num[age_iter_ss] <- stock__num[age_younger_iter_ss]
stock__wgt[age_iter_ss] <- stock__wgt[age_younger_iter_ss]
stock_ss(stock__num, age = default, vec = age) <- stock_ss(stock__num, age = default - 1, vec = age)
stock_ss(stock__wgt, age = default, vec = age) <- stock_ss(stock__wgt, age = default - 1, vec = age)
}
}))
}, list(
final_year_f = final_year_f,
run_f = run_f,
age_iter_ss = age_iter_ss,
age_younger_iter_ss = age_younger_iter_ss))))
run_f = run_f )))

return(as.list(out))
}
8 changes: 4 additions & 4 deletions inttest/codegeneration-defaults/model.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -564,17 +564,17 @@ structure(function (param)
comment("Check stock has remained finite for this step")
if (age == fish__maxage) {
comment("Oldest fish is a plus-group, combine with younger individuals")
fish__wgt[, , fish__age_idx] <- ratio_add_vec(fish__wgt[, , fish__age_idx], fish__num[, , fish__age_idx], fish__wgt[, , fish__age_idx - 1L], fish__num[, , fish__age_idx - 1L])
fish__num[, , fish__age_idx] <- fish__num[, , fish__age_idx] + fish__num[, , fish__age_idx - 1L]
fish__wgt[, , fish__age_idx] <- ratio_add_vec(fish__wgt[, , fish__age_idx], fish__num[, , fish__age_idx], fish__wgt[, , fish__age_idx - 1], fish__num[, , fish__age_idx - 1])
fish__num[, , fish__age_idx] <- fish__num[, , fish__age_idx] + fish__num[, , fish__age_idx - 1]
}
else if (age == fish__minage) {
comment("Empty youngest fish age-group")
fish__num[, , fish__age_idx] <- 0
}
else {
comment("Move fish age-group to next one up")
fish__num[, , fish__age_idx] <- fish__num[, , fish__age_idx - 1L]
fish__wgt[, , fish__age_idx] <- fish__wgt[, , fish__age_idx - 1L]
fish__num[, , fish__age_idx] <- fish__num[, , fish__age_idx - 1]
fish__wgt[, , fish__age_idx] <- fish__wgt[, , fish__age_idx - 1]
}
}
}
Expand Down
16 changes: 8 additions & 8 deletions inttest/codegeneration/ling.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -699,17 +699,17 @@ structure(function (param)
comment("Move oldest ling_imm into ling_imm_movement")
ling_imm_movement__transitioning_num[, , (1)] <- ling_imm__num[, , ling_imm__age_idx]
ling_imm_movement__transitioning_wgt[, , (1)] <- ling_imm__wgt[, , ling_imm__age_idx]
ling_imm__num[, , ling_imm__age_idx] <- ling_imm__num[, , ling_imm__age_idx - 1L]
ling_imm__wgt[, , ling_imm__age_idx] <- ling_imm__wgt[, , ling_imm__age_idx - 1L]
ling_imm__num[, , ling_imm__age_idx] <- ling_imm__num[, , ling_imm__age_idx - 1]
ling_imm__wgt[, , ling_imm__age_idx] <- ling_imm__wgt[, , ling_imm__age_idx - 1]
}
else if (age == ling_imm__minage) {
comment("Empty youngest ling_imm age-group")
ling_imm__num[, , ling_imm__age_idx] <- 0
}
else {
comment("Move ling_imm age-group to next one up")
ling_imm__num[, , ling_imm__age_idx] <- ling_imm__num[, , ling_imm__age_idx - 1L]
ling_imm__wgt[, , ling_imm__age_idx] <- ling_imm__wgt[, , ling_imm__age_idx - 1L]
ling_imm__num[, , ling_imm__age_idx] <- ling_imm__num[, , ling_imm__age_idx - 1]
ling_imm__wgt[, , ling_imm__age_idx] <- ling_imm__wgt[, , ling_imm__age_idx - 1]
}
}
}
Expand All @@ -722,17 +722,17 @@ structure(function (param)
comment("Check stock has remained finite for this step")
if (age == ling_mat__maxage) {
comment("Oldest ling_mat is a plus-group, combine with younger individuals")
ling_mat__wgt[, , ling_mat__age_idx] <- ratio_add_vec(ling_mat__wgt[, , ling_mat__age_idx], ling_mat__num[, , ling_mat__age_idx], ling_mat__wgt[, , ling_mat__age_idx - 1L], ling_mat__num[, , ling_mat__age_idx - 1L])
ling_mat__num[, , ling_mat__age_idx] <- ling_mat__num[, , ling_mat__age_idx] + ling_mat__num[, , ling_mat__age_idx - 1L]
ling_mat__wgt[, , ling_mat__age_idx] <- ratio_add_vec(ling_mat__wgt[, , ling_mat__age_idx], ling_mat__num[, , ling_mat__age_idx], ling_mat__wgt[, , ling_mat__age_idx - 1], ling_mat__num[, , ling_mat__age_idx - 1])
ling_mat__num[, , ling_mat__age_idx] <- ling_mat__num[, , ling_mat__age_idx] + ling_mat__num[, , ling_mat__age_idx - 1]
}
else if (age == ling_mat__minage) {
comment("Empty youngest ling_mat age-group")
ling_mat__num[, , ling_mat__age_idx] <- 0
}
else {
comment("Move ling_mat age-group to next one up")
ling_mat__num[, , ling_mat__age_idx] <- ling_mat__num[, , ling_mat__age_idx - 1L]
ling_mat__wgt[, , ling_mat__age_idx] <- ling_mat__wgt[, , ling_mat__age_idx - 1L]
ling_mat__num[, , ling_mat__age_idx] <- ling_mat__num[, , ling_mat__age_idx - 1]
ling_mat__wgt[, , ling_mat__age_idx] <- ling_mat__wgt[, , ling_mat__age_idx - 1]
}
}
}
Expand Down

0 comments on commit ce05843

Please sign in to comment.