inst/doc/Joint_effects.R

In multiscape: Multi-Action, Multi-Objective Spatial Planning

## ----setup, include=FALSE-----------------------------------------------------
knitr::opts_chunk$set(collapse = TRUE, comment = "#>")
library(multiscape)

## ----inputs-------------------------------------------------------------------
base <- create_problem(
  data.frame(id = 10L, cost = 0), data.frame(id = 1L, name = "habitat"),
  data.frame(pu = 10L, feature = 1L, amount = 100)
) |>
  add_actions(data.frame(id = c("restore", "control")), cost = 1) |>
  add_action_sets(data.frame(set = c("restore_control", "restore_control"),
                             action = c("restore", "control"))) |>
  add_constraint_action_cardinality(2, "max")
effects <- data.frame(action = c("restore", "control", "restore_control"),
                      feature = "habitat", effect = c(30, 20, 70))
problem <- add_effects(base, effects)
problem$data$effect_terms[, c("action", "total_effect", "effect")]

## ----equivalent-inputs--------------------------------------------------------
outcomes <- data.frame(action = effects$action, feature = "habitat", outcome = c(130, 120, 170))
changes <- data.frame(action = effects$action, feature = "habitat", relative_change = c(.3, .2, .7))
outcome_problem <- add_effects(base, outcomes)
relative_problem <- add_effects(base, changes)
stopifnot(isTRUE(all.equal(problem$data$effect_terms, outcome_problem$data$effect_terms)),
          isTRUE(all.equal(problem$data$effect_terms, relative_problem$data$effect_terms)))

## ----provenance---------------------------------------------------------------
problem$data$effects_input
problem$data$joint_effects[, c("action", "effect", "action_outcome")]
problem$data$effects_meta[c("missing_interactions", "missing_individual_effects")]

## ----methods------------------------------------------------------------------
mo_base <- problem |>
  add_constraint_action_cardinality(1, "min") |>
  add_objective_min_cost(alias = "cost", include_pu_cost = FALSE) |>
  add_objective_max_effect(alias = "benefit") |>
  set_solver_cbc(gap_limit = 0, verbose = FALSE)
methods <- list(
  weighted = set_method_weighted_sum(mo_base, aliases = c("cost", "benefit"),
    normalize_weights = FALSE, runs = set_runs_manual(data.frame(weight_cost = 1, weight_benefit = 1))),
  epsilon = set_method_epsilon_constraint(mo_base, primary = "cost", aliases = c("cost", "benefit"),
    runs = set_runs_manual(data.frame(eps_benefit = 69))),
  augmecon = set_method_augmecon(mo_base, primary = "cost", aliases = c("cost", "benefit"),
    runs = set_runs_manual(data.frame(eps_benefit = 69)))
)

## ----solve-mo, eval=requireNamespace("rcbc", quietly = TRUE)------------------
solutions <- lapply(methods, solve)
lapply(solutions, get_objectives)
for (solution in solutions) {
  objective <- get_objectives(solution)
  feature <- get_features(solution)
  stopifnot(objective$cost == 2, objective$benefit == 70,
            feature$selected_baseline == 100, feature$selected_amount_after == 170)
}

## ----negative-interaction-----------------------------------------------------
negative_input <- effects
negative_input$effect[negative_input$action == "restore_control"] <- 40
negative <- add_effects(base, negative_input)
negative$data$effect_terms[, c("action", "total_effect", "effect")]
economic <- negative |>
  add_profit(c(restore = 10, control = 9)) |>
  add_objective_max_profit(alias = "profit") |>
  set_solver_cbc(gap_limit = 0, verbose = FALSE)

## ----solve-negative, eval=requireNamespace("rcbc", quietly = TRUE)------------
solution <- solve(economic)
get_features(solution)
stopifnot(get_features(solution)$selected_net == 40,
          get_features(solution)$selected_benefit == 40,
          get_features(solution)$selected_loss == 0,
          get_features(solution)$selected_amount_after == 140)

## ----signed-objectives--------------------------------------------------------
benefit_problem <- negative |> add_objective_max_effect(alias = "benefit")
loss_problem <- negative |>
  add_constraint_action_cardinality(2, "equal") |>
  add_objective_min_loss(alias = "loss")

## ----solve-signed-objectives, eval=requireNamespace("rcbc", quietly = TRUE)----
benefit_solution <- solve(set_solver_cbc(benefit_problem, gap_limit = 0, verbose = FALSE))
loss_solution <- solve(set_solver_cbc(loss_problem, gap_limit = 0, verbose = FALSE))
stopifnot(get_objectives(benefit_solution)$benefit == 40,
          get_objectives(loss_solution)$loss == 0)

## ----deteriorating-joint-outcome----------------------------------------------
deteriorating_input <- effects
deteriorating_input$effect[deteriorating_input$action == "restore_control"] <- -10
deteriorating <- add_effects(base, deteriorating_input) |>
  add_constraint_action_cardinality(2, "equal")

## ----solve-deterioration, eval=requireNamespace("rcbc", quietly = TRUE)-------
net_solution <- deteriorating |> add_objective_max_effect(alias = "benefit") |>
  set_solver_cbc(gap_limit = 0, verbose = FALSE) |> solve()
loss_solution <- deteriorating |> add_objective_min_loss(alias = "loss") |>
  set_solver_cbc(gap_limit = 0, verbose = FALSE) |> solve()
stopifnot(get_objectives(net_solution)$benefit == -10,
          get_objectives(loss_solution)$loss == 10,
          get_features(loss_solution)$selected_amount_after == 90)

## ----joint-target-------------------------------------------------------------
target_problem <- negative |>
  add_constraint_targets_absolute(140) |>
  add_objective_min_cost(alias = "cost")

## ----solve-joint-target, eval=requireNamespace("rcbc", quietly = TRUE)--------
target_solution <- solve(set_solver_cbc(target_problem, gap_limit = 0, verbose = FALSE))
get_targets(target_solution)
stopifnot(get_objectives(target_solution)$cost == 2,
          get_features(target_solution)$selected_amount_after == 140,
          get_targets(target_solution)$achieved == 140)