Nothing
R/internal.R
In multiscape: Multi-Action, Multi-Objective Spatial Planning
Defines functions
.pa_as_int_id
.pa_validate_positive_integer_ids
.pa_get_objectives_internal
.pa_get_objective_matrix
.pa_action_names_from_internal_ids
.pa_feature_names_from_internal_ids
.pa_active_objective_alias
.pa_apply_budget_constraints_if_present
.pa_apply_group_area_constraints_if_present
.pa_store_budget_constraints
.pa_store_area_constraints
.pa_compile_problem
.pa_model_is_current
.validate_split_effects
.pa_solve_single_problem
.pa_add_action_labels
.pa_add_feature_labels
.pa_subset_to_string
.pa_resolve_feature_subset
.pa_set_active_and_register_objective
.pa_resolve_action_subset
.pa_log_add
.pa_clone_data
.pa_deepcopy_data
.pa_build_model_prepare_needs_cpp
.pa_build_model_set_needs_from_objective
.pa_build_model_init_needs
.pa_needs_default
.pa_swap_edges
.pa_rbind_fill
.pa_get_pu_sf_aligned
.pa_coords_from_input
.pa_store_relation
.pa_ensure_pu_index
.pa_has_sf
.pa_fast_extract
.pa_register_objective
.pa_create_problem_tabular_impl
.pa_apply_runtime_updates_to_model
.pa_abort
.pa_model_frag_vars_summary
.pa_action_weights_vector
.pa_validate_relation
.pa_add_linear_constraint
.pa_ensure_model_snapshot
.pa_get_area_vec
.pa_extract_solution_tables
.pa_apply_solver_capabilities
.pa_get_solve_args
.pa_spatial_relations_summary
.pa_has_coords
.is_raster_path
`%||%`
.pa_model_dims
.pa_has_model
.pa_nrow0
.pa_get_action_cost_vec
.pa_get_cost_vec
.pa_safe_range
.pa_cli_box_chars
.pa_cli_theme
.pa_model_from_ptr
.pa_positive_objective_scale
.pa_cbc_complete_dimensions
.pa_apply_area_constraints_if_present
.pa_refresh_model_snapshot
.pa_apply_targets_if_present
.get_dist_effects_model
.get_dist_benefit_model_from_effects
.pa_feature_potential
.pa_feature_totals
.pa_store_targets
.pa_constraint_name
.pa_target_actions
.pa_assert_unconfigured
.pa_parse_targets
available_to_solve
getStatus
pproto
no_extra_arguments
#' No extra arguments
#'
#' Check that no additional unused arguments have been supplied to a function
#' through the `...`.
#'
#' @param ... arguments that are not used.
#'
#' @return `logical` indicating success.
#'
#' @noRd
no_extra_arguments <- function(...) {
return(length(list(...)) == 0)
}
assertthat::on_failure(no_extra_arguments) <- function(call, env) {
"unused arguments"
}
#' Create a new `pproto` object
#'
#' Construct a new object with `pproto`. This object system is inspired
#' from the `ggproto` system used in the `ggplot2` package.
#'
#' @param _class Class name to assign to the object. This is stored as the class
#' attribute of the object. This is optional: if `NULL` (the default),
#' no class name will be added to the object.
#'
#' @param _inherit `pproto` object to inherit from. If `NULL`, don"t
#' inherit from any object.
#'
#' @param ... A list of members to add to the new `pproto` object.
#'
#' @examples
#' Adder <- pproto("Adder",
#' x = 0,
#' add = function(self, n) {
#' self$x <- self$x + n
#' self$x
#' }
#' )
#'
#' Adder$add(10)
#' Adder$add(10)
#'
#' Abacus <- pproto("Abacus", Adder,
#' subtract = function(self, n) {
#' self$x <- self$x - n
#' self$x
#' }
#' )
#' Abacus$add(10)
#' Abacus$subtract(10)
#' @noRd
pproto <- function(`_class` = NULL, `_inherit` = NULL, ...) {
assertthat::assert_that(
assertthat::is.string(`_class`) || is.null(`_class`),
inherits(`_inherit`, "pproto") || is.null(`_inherit`)
)
# Create proto object without retaining the caller frame.
# proto::proto() defaults to envir = new.env(parent = parent.frame()),
# which can capture large temporary objects from pproto()/assign_fields().
#
# Use the package namespace as the parent environment so proto methods can
# still find internal helpers such as .pa_cli_box_chars().
new_proto <- function(...) {
ns <- environment(pproto)
proto::proto(
envir = new.env(parent = ns),
funEnvir = ns,
...
)
}
# copy objects from one proto to another proto
assign_fields <- function(p1, p2) {
if (!inherits(p2, "proto")) {
return()
}
for (i in p2$ls()) {
if (inherits(p2[[i]], "proto")) {
p1[[i]] <- new_proto()
class(p1[[i]]) <- class(p2[[i]])
assign_fields(p1[[i]], p2[[i]])
} else {
p1[[i]] <- p2[[i]]
}
}
assign_fields(p1, p2$.super)
}
# create new proto without retaining the caller frame
p <- new_proto()
if (!is.null(`_inherit`)) {
assign_fields(p, `_inherit`)
class(p) <- class(`_inherit`)
} else {
class(p) <- c("pproto", class(p))
}
# assign members to new proto without retaining the caller frame
dots <- new_proto(...)
assign_fields(p, dots)
if (!is.null(`_class`)) {
class(p) <- c(`_class`, class(p))
}
p
}
#' Get status
#'
#' Construct a new object with `pproto`. This object system is inspired
#' from the `ggproto` system used in the `ggplot2` package.
#'
#' @param _class Class name to assign to the object. This is stored as the class
#' attribute of the object. This is optional: if `NULL` (the default),
#' no class name will be added to the object.
#'
#' @param _inherit `pproto` object to inherit from. If `NULL`, don"t
#' inherit from any object.
#'
#' @param ... A list of members to add to the new `pproto` object.
#'
#' @noRd
getStatus <- function(x) {
# Preferred structure: Solution with diagnostics
d <- NULL
if (!is.null(x$diagnostics)) {
d <- x$diagnostics
} else {
d <- x
}
code <- d$status_code %||% d$status %||% NA_integer_
code <- as.integer(code)[1]
if (is.na(code)) return("unknown")
switch(
as.character(code),
"0" = "optimal",
"1" = "infeasible_or_unbounded",
"2" = "time_limit_feasible",
"3" = "time_limit_no_solution",
"4" = "solution_limit",
"999" = "unknown",
paste0("unknown(", code, ")")
)
}
#' Check if solvers are working
#'
#' Provides the status of solver. Being TRUE if it's working fine and FALSE in otherwise.
#'
#' @param package `character` object. Posible values: "gurobi", "cplex", and "symphony".
#'
#' @examples
#' available_to_solve("cplex")
#'
#' @noRd
available_to_solve <- function(package = ""){
# define primitive data
nPlants <- 1
nWarehouses <- 1
# Warehouse demand in thousands of units
Demand <- c(10)
# Plant capacity in thousands of units
Capacity <- c(20)
# Fixed costs for each plant
FixedCosts <- c(100)
# Transportation costs per thousand units
TransCosts <- c(100)
flowidx <- function(w, p) {nPlants * (w-1) + p}
# Build model
model <- list()
model$modelname <- 'facility'
model$modelsense <- 'min'
# initialize data for variables
model$lb <- 0
model$ub <- c(rep(1, nPlants), rep(Inf, nPlants * nWarehouses))
model$vtype <- c(rep('B', nPlants), rep('C', nPlants * nWarehouses))
model$obj <- c(FixedCosts, TransCosts)
model$varnames <- c(paste0(rep('Open',nPlants),1:nPlants),
sprintf('Trans%d,%d',
c(mapply(rep,1:nWarehouses,nPlants)),
1:nPlants))
# build production constraint matrix
A1 <- Matrix::spMatrix(nPlants, nPlants, i = c(1:nPlants), j = (1:nPlants), x = -Capacity)
A2 <- Matrix::spMatrix(nPlants, nPlants * nWarehouses,
i = c(mapply(rep, 1:nPlants, nWarehouses)),
j = mapply(flowidx,1:nWarehouses,c(mapply(rep,1:nPlants,nWarehouses))),
x = rep(1, nWarehouses * nPlants))
A3 <- Matrix::spMatrix(nWarehouses, nPlants)
A4 <- Matrix::spMatrix(nWarehouses, nPlants * nWarehouses,
i = c(mapply(rep, 1:nWarehouses, nPlants)),
j = mapply(flowidx,c(mapply(rep,1:nWarehouses,nPlants)),1:nPlants),
x = rep(1, nPlants * nWarehouses))
model$A <- rbind(cbind(A1, A2), cbind(A3, A4))
model$rhs <- c(rep(0, nPlants), Demand)
model$sense <- c(rep('<=', nPlants), rep('==', nWarehouses))
model$constrnames <- c(sprintf('Capacity%d',1:nPlants),
sprintf('Demand%d',1:nWarehouses))
if(package == "gurobi"){
# set parameters
params <- list()
params$TimeLimit <- 0.01
params$LogToConsole <- 0
model$sense <- replace(model$sense, model$sense == "==", "=")
sol <- invisible(try(gurobi::gurobi(model, params), silent = TRUE))
}
else if(package == "cbc"){
# set parameters
cbc_args <- list()
cbc_args$sec <- "0.01"
cbc_args$log <- "0"
constraints_minus_equal <- which(model$sense != "<=")
constraints_plus_equal <- which(model$sense == "<=")
row_ub <- model$rhs
row_ub[constraints_minus_equal] <- Inf
row_lb <- model$rhs
row_lb[constraints_plus_equal] <- -Inf
sol <- invisible(try(rcbc::cbc_solve(obj = model$obj,
mat = model$A,
is_integer = ifelse(model$vtype == "B", TRUE, FALSE),
row_ub = row_ub,
row_lb = row_lb,
col_lb = rep(0, length(model$vtype)),
col_ub = model$ub,
max = ifelse(model$modelsense == "min", FALSE, TRUE),
cbc_args = cbc_args), silent = TRUE))
}
else if(package == "cplex"){
model$sense[model$sense == ">="] <- "G"
model$sense[model$sense == "=="] <- "E"
model$sense[model$sense == "<="] <- "L"
# set parameters
params <- list()
params$tilim <- 0.01
params$trace <- 0
sol <- try(Rcplex::Rcplex(cvec = model$obj,
Amat = model$A,
bvec = model$rhs,
lb = model$lb,
ub = model$ub,
objsense = model$modelsense,
sense = model$sense,
vtype = model$vtype,
control = params),
silent = TRUE)
}
else if(package == "symphony"){
model$mat <- model$A
model$dir <- model$sense
model$max <- ifelse(model$modelsense == "min", FALSE, TRUE)
model$types <- model$vtype
sol <- invisible(try(Rsymphony::Rsymphony_solve_LP(model$obj,
model$mat,
model$dir,
model$rhs,
model$bounds,
model$types,
model$max,
gap_limit = 100,
time_limit = 0.01),
silent = TRUE))
}
if(inherits(sol, "try-error")){
return(FALSE)
}
else{
return(TRUE)
}
}
# -------------------------------------------------------------------------
# Internal helpers TARGETS
# -------------------------------------------------------------------------
.pa_parse_targets <- function(x, targets, features = NULL) {
feats <- x$data$features
if (is.null(feats) || nrow(feats) == 0) {
stop("x$data$features is missing/empty.", call. = FALSE)
}
if (!("id" %in% names(feats))) {
stop("x$data$features must contain column 'id'.", call. = FALSE)
}
feat_ids <- as.numeric(feats$id)
feat_names <- if ("name" %in% names(feats)) as.character(feats$name) else rep(NA_character_, length(feat_ids))
.feature_name_from_id <- function(fid) {
fid <- as.numeric(fid)
feat_names[match(fid, feat_ids)]
}
# helper: map a feature identifier (id or name) to numeric id
.map_feature <- function(v) {
if (is.null(v)) return(NULL)
if (is.factor(v)) v <- as.character(v)
if (is.numeric(v) || is.integer(v)) {
v <- as.numeric(v)
bad <- v[!v %in% feat_ids]
if (length(bad) > 0) {
stop("Unknown feature id(s): ", paste(unique(bad), collapse = ", "), call. = FALSE)
}
return(v)
}
if (is.character(v)) {
sup <- suppressWarnings(as.numeric(v))
is_numlike <- !is.na(sup) & nzchar(v)
out <- rep(NA_real_, length(v))
if (any(is_numlike)) {
vv <- sup[is_numlike]
bad <- vv[!vv %in% feat_ids]
if (length(bad) == 0) out[is_numlike] <- vv
}
need_name <- is.na(out)
if (any(need_name)) {
if (!("name" %in% names(feats))) {
stop("Targets reference feature names, but x$data$features has no 'name' column.", call. = FALSE)
}
m <- match(v[need_name], feat_names)
bad <- v[need_name][is.na(m)]
if (length(bad) > 0) {
stop(
"Unknown feature name(s): ", paste0("'", unique(bad), "'", collapse = ", "),
". Valid names include: ", paste0("'", utils::head(feat_names, 10), "'", collapse = ", "),
if (length(feat_names) > 10) " ..." else "",
call. = FALSE
)
}
out[need_name] <- feat_ids[m]
}
return(as.numeric(out))
}
stop("Unsupported feature identifier type.", call. = FALSE)
}
.resolve_target_features <- function(features) {
if (is.null(features)) return(feat_ids)
f <- .map_feature(features)
if (length(f) == 0) {
stop("features resolved to an empty set.", call. = FALSE)
}
f <- unique(as.numeric(f))
f
}
.finalize_targets <- function(f, t) {
dt <- data.frame(
feature = as.numeric(f),
feature_name = .feature_name_from_id(f),
target_raw = as.numeric(t),
stringsAsFactors = FALSE
)
dt <- dt[order(dt$feature), , drop = FALSE]
if (anyDuplicated(dt$feature)) {
stop("Duplicate targets for the same feature. Please de-duplicate.", call. = FALSE)
}
dt
}
selected_features <- .resolve_target_features(features)
# 1) data.frame(feature, target)
if (inherits(targets, "data.frame")) {
if (!all(c("feature", "target") %in% names(targets))) {
stop("If targets is a data.frame it must contain columns 'feature' and 'target'.", call. = FALSE)
}
if (!is.null(features)) {
warning(
"'features' was supplied but targets is a data.frame with an explicit 'feature' column. ",
"Ignoring 'features'.",
call. = FALSE
)
}
f <- .map_feature(targets$feature)
t <- as.numeric(targets$target)
if (any(is.na(t))) stop("Targets contain NA values.", call. = FALSE)
return(.finalize_targets(f, t))
}
# 2) matrix (one column) with optional rownames
if (is.matrix(targets)) {
if (ncol(targets) != 1) {
stop("If targets is a matrix it must have exactly 1 column.", call. = FALSE)
}
t <- as.numeric(targets[, 1])
if (any(is.na(t))) stop("Targets contain NA values.", call. = FALSE)
rn <- rownames(targets)
if (!is.null(rn) && length(rn) == length(t)) {
if (!is.null(features)) {
warning(
"'features' was supplied but targets is a matrix with rownames. Ignoring 'features'.",
call. = FALSE
)
}
f <- .map_feature(rn)
return(.finalize_targets(f, t))
}
if (length(t) == 1) {
return(.finalize_targets(selected_features, rep(t, length(selected_features))))
}
if (length(t) != length(selected_features)) {
stop(
"Matrix targets without rownames must have nrow = 1 or nrow = number of targeted features (",
length(selected_features), ").",
call. = FALSE
)
}
return(.finalize_targets(selected_features, t))
}
# 3) scalar numeric -> recycle
if (is.numeric(targets) && length(targets) == 1) {
t <- as.numeric(targets)
if (is.na(t)) stop("Target is NA.", call. = FALSE)
return(.finalize_targets(selected_features, rep(t, length(selected_features))))
}
# 4) numeric vector
if (is.numeric(targets) && length(targets) > 1) {
t <- as.numeric(targets)
if (any(is.na(t))) stop("Targets contain NA values.", call. = FALSE)
nm <- names(targets)
if (!is.null(nm) && any(nzchar(nm))) {
if (!is.null(features)) {
warning(
"'features' was supplied but targets is a named vector. Ignoring 'features'.",
call. = FALSE
)
}
f <- .map_feature(nm)
return(.finalize_targets(f, t))
}
if (length(t) != length(selected_features)) {
stop(
"Un-named numeric targets must have length 1 or length equal to the number of targeted features (",
length(selected_features), ").",
call. = FALSE
)
}
return(.finalize_targets(selected_features, t))
}
# 5) character
if (is.character(targets)) {
if (length(targets) == 1 && grepl("^\\s*[-+]?[0-9]*\\.?[0-9]+\\s*$", targets)) {
t <- as.numeric(targets)
return(.finalize_targets(selected_features, rep(t, length(selected_features))))
}
if (any(grepl("=", targets, fixed = TRUE))) {
if (!is.null(features)) {
warning(
"'features' was supplied but targets uses 'feature=target' syntax. Ignoring 'features'.",
call. = FALSE
)
}
parts <- strsplit(targets, "=", fixed = TRUE)
feat_part <- vapply(parts, `[[`, character(1), 1)
val_part <- vapply(parts, `[[`, character(1), 2)
f <- .map_feature(trimws(feat_part))
t <- as.numeric(trimws(val_part))
if (any(is.na(t))) {
stop("Could not parse numeric target values from character input.", call. = FALSE)
}
return(.finalize_targets(f, t))
}
stop(
"Unsupported character targets format. Use 'feature=target' pairs or a single numeric string.",
call. = FALSE
)
}
stop("Unsupported targets format.", call. = FALSE)
}
# Configurations are single-assignment; defaults computed by readers do not
# populate these fields. Check before cloning or touching cached models.
.pa_assert_unconfigured <- function(x, fields, label, constructor) {
stopifnot(inherits(x, "Problem"))
if (any(vapply(fields, function(field) !is.null(x$data[[field]]), logical(1)))) {
stop(label, " already defined. ", constructor, " can only be called once per problem. ",
"Rebuild from the problem before this definition to change it.", call. = FALSE)
}
invisible(TRUE)
}
.pa_target_actions <- function(x, actions) {
if (is.null(actions)) return(NA_character_)
.pa_subset_to_string(.pa_resolve_action_subset(x, actions)$id)
}
.pa_constraint_name <- function(x, family, proposed, explicit = FALSE) {
names_used <- x$data$constraints[[family]]$name %||% character()
if (!(proposed %in% names_used)) return(proposed)
if (explicit) {
stop("Constraint name '", proposed, "' already exists in ", family, ".", call. = FALSE)
}
index <- 2L
while (paste0(proposed, "_", index) %in% names_used) index <- index + 1L
paste0(proposed, "_", index)
}
.pa_store_targets <- function(x, targets_df) {
stopifnot(inherits(x, "Problem"))
stopifnot(inherits(targets_df, "data.frame"))
stopifnot(all(c("feature", "type", "target_value") %in% names(targets_df)))
# normalize minimal fields
targets_df$feature <- as.integer(targets_df$feature)
targets_df$type <- as.character(targets_df$type)
targets_df$target_value <- as.numeric(targets_df$target_value)
# ensure actions column exists
if (!("actions" %in% names(targets_df))) {
targets_df$actions <- NA_character_
}
targets_df$actions <- as.character(targets_df$actions)
key_new <- paste(targets_df$feature, targets_df$type, targets_df$actions, sep = "||")
if (anyDuplicated(key_new)) {
stop("Duplicated targets for the same feature and action scope.", call. = FALSE)
}
valid_types <- c("actions")
bad_type <- setdiff(unique(targets_df$type), valid_types)
if (length(bad_type) > 0) {
stop("Unknown target types: ", paste(bad_type, collapse = ", "), call. = FALSE)
}
# initialize if empty
if (is.null(x$data$targets) || !inherits(x$data$targets, "data.frame") || nrow(x$data$targets) == 0) {
x$data$targets <- targets_df
if (!is.null(x$data$model_ptr)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$model_dirty <- TRUE
}
return(x)
}
old <- x$data$targets
old$feature <- as.integer(old$feature)
old$type <- as.character(old$type)
old$target_value <- as.numeric(old$target_value)
# backward compatibility: migrate old subset column if present
if (!("actions" %in% names(old))) {
if ("subset" %in% names(old)) {
old$actions <- as.character(old$subset)
} else {
old$actions <- NA_character_
}
}
old$actions <- as.character(old$actions)
# Absolute and relative targets share the same feature/action identity.
key_old <- paste0(old$feature, "||", old$type, "||", old$actions)
key_new <- paste0(targets_df$feature, "||", targets_df$type, "||", targets_df$actions)
overlap <- intersect(key_old, key_new)
if (length(overlap) > 0) {
stop(
"A target already exists for the same feature and action scope. ",
"Rebuild from the problem before this target to change it. ",
"Example key: ", overlap[1],
call. = FALSE
)
}
x$data$targets <- rbind(old, targets_df)
if (!is.null(x$data$model_ptr)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$model_dirty <- TRUE
}
x
}
.pa_feature_totals <- function(x) {
df <- x$data$dist_features
if (is.null(df) || nrow(df) == 0) {
stop("Need x$data$dist_features to compute baseline totals.", call. = FALSE)
}
stopifnot(all(c("feature","amount") %in% names(df)))
f <- as.numeric(df$feature)
a <- as.numeric(df$amount)
a[!is.finite(a) | is.na(a)] <- 0
out <- tapply(a, f, sum, na.rm = TRUE)
out[is.na(out)] <- 0
out
}
.pa_feature_potential <- function(x, value_col = "benefit") {
de <- x$data$dist_effects_model %||% x$data$dist_effects
if (is.null(de) || nrow(de) == 0) {
stop("Need dist_effects to compute potential. Run add_effects()/add_benefits() first.", call. = FALSE)
}
stopifnot(all(c("feature", value_col) %in% names(de)))
f <- as.numeric(de$feature)
v <- as.numeric(de[[value_col]])
# potential is sum of positive contributions only
v_pos <- pmax(v, 0)
v_pos[!is.finite(v_pos) | is.na(v_pos)] <- 0
out <- tapply(v_pos, f, sum, na.rm = TRUE)
out[is.na(out)] <- 0
out
}
# -----------------------------------------------------------------------------
# Apply targets to the active C++ model (helper)
# -----------------------------------------------------------------------------
# This helper is meant to be called INSIDE problem() after:
# - base variables have been added
# - structural constraints have been added
# - objective has been set (optional)
#
# It will:
# - read x$data$targets (data.frame)
# - decide per-feature whether we have conservation-only, recovery-only, or mixed
# - call the corresponding Rcpp function(s)
# - store a lightweight "applied_targets" summary in x$data$model_args
#
# Assumptions (consistent with your design):
# - x$data$model_ptr exists and is an XPtr<OptimizationProblem>
# - target_value is already ABSOLUTE in x$data$targets
# - conservation-only uses z variables + dist_features amounts
# - recovery-only uses x variables + dist_benefit deltas (can be + or -)
# - mixed (option 1) uses total = (conservation baseline) + (action deltas),
# with target = Tc + Tr if both targets exist for a feature.
# -----------------------------------------------------------------------------
# helper: get model-ready benefit table from dist_effects
.get_dist_benefit_model_from_effects <- function(x, benefit_col = "benefit") {
de <- x$data$dist_effects_model %||% x$data$dist_effects
if (is.null(de) || !inherits(de, "data.frame") || nrow(de) == 0) {
return(NULL)
}
benefit_col <- as.character(benefit_col)[1]
if (is.na(benefit_col) || !nzchar(benefit_col)) {
stop("`benefit_col` must be a non-empty string.", call. = FALSE)
}
if (!(benefit_col %in% names(de))) {
stop("dist_effects is missing column '", benefit_col, "'.", call. = FALSE)
}
out <- de
if ("feature" %in% names(out)) out$feature <- as.integer(out$feature)
if ("internal_pu" %in% names(out)) out$internal_pu <- as.integer(out$internal_pu)
if ("internal_action" %in% names(out)) out$internal_action <- as.integer(out$internal_action)
if ("internal_feature" %in% names(out)) out$internal_feature <- as.integer(out$internal_feature)
out$benefit <- as.numeric(out[[benefit_col]])
if (anyNA(out$benefit) || any(!is.finite(out$benefit))) {
stop(
"Column '", benefit_col, "' in dist_effects contains NA or non-finite values.",
call. = FALSE
)
}
out
}
.get_dist_effects_model <- function(x, mode = c("benefit", "loss", "delta")) {
mode <- match.arg(mode)
de <- x$data$dist_effects_model %||% x$data$dist_effects
if (is.null(de) || !inherits(de, "data.frame") || nrow(de) == 0) {
return(NULL)
}
out <- de
if ("feature" %in% names(out)) out$feature <- as.integer(out$feature)
if ("internal_pu" %in% names(out)) out$internal_pu <- as.integer(out$internal_pu)
if ("internal_action" %in% names(out)) out$internal_action <- as.integer(out$internal_action)
if ("internal_feature" %in% names(out)) out$internal_feature <- as.integer(out$internal_feature)
if (mode == "benefit") {
if (!("benefit" %in% names(out))) {
stop("dist_effects is missing column 'benefit'.", call. = FALSE)
}
out$benefit <- as.numeric(out$benefit)
if (anyNA(out$benefit) || any(!is.finite(out$benefit))) {
stop("dist_effects$benefit contains NA or non-finite values.", call. = FALSE)
}
out$effect <- out$benefit
return(out)
}
if (mode == "loss") {
if (!("loss" %in% names(out))) {
stop("dist_effects is missing column 'loss'.", call. = FALSE)
}
out$loss <- as.numeric(out$loss)
if (anyNA(out$loss) || any(!is.finite(out$loss))) {
stop("dist_effects$loss contains NA or non-finite values.", call. = FALSE)
}
out$effect <- out$loss
return(out)
}
# mode == "delta"
if (!("benefit" %in% names(out)) && !("loss" %in% names(out))) {
stop(
"dist_effects must contain at least one of 'benefit' or 'loss' to compute delta.",
call. = FALSE
)
}
if (!("benefit" %in% names(out))) out$benefit <- 0
if (!("loss" %in% names(out))) out$loss <- 0
out$benefit <- as.numeric(out$benefit)
out$loss <- as.numeric(out$loss)
if (anyNA(out$benefit) || any(!is.finite(out$benefit))) {
stop("dist_effects$benefit contains NA or non-finite values.", call. = FALSE)
}
if (anyNA(out$loss) || any(!is.finite(out$loss))) {
stop("dist_effects$loss contains NA or non-finite values.", call. = FALSE)
}
out$effect <- out$benefit - out$loss
out
}
.pa_apply_targets_if_present <- function(x,
zero_tol = 1e-12) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$targets) || !inherits(x$data$targets, "data.frame") || nrow(x$data$targets) == 0) {
return(invisible(x))
}
if (is.null(x$data$model_ptr)) {
stop("No active model pointer found in x$data$model_ptr. Run add_constraint_targets_*() before applying targets.", call. = FALSE)
}
t <- x$data$targets
req <- c("feature", "type", "target_value")
miss <- setdiff(req, names(t))
if (length(miss) > 0) {
stop("x$data$targets is missing required columns: ", paste(miss, collapse = ", "), call. = FALSE)
}
# backward compatibility: migrate subset -> actions
if (!("actions" %in% names(t))) {
if ("subset" %in% names(t)) {
t$actions <- as.character(t$subset)
} else {
t$actions <- NA_character_
}
}
t$feature <- as.integer(t$feature)
t$type <- as.character(t$type)
t$actions <- as.character(t$actions)
t$target_value <- as.numeric(t$target_value)
bad_type <- setdiff(unique(t$type), c("actions"))
if (length(bad_type) > 0) {
stop("Unknown target types in x$data$targets: ", paste(bad_type, collapse = ", "), call. = FALSE)
}
# ------------------------------------------------------------------
# 1) exact duplicates by (feature, type, actions) are NOT allowed
# ------------------------------------------------------------------
key_exact <- paste0(
t$feature, "||",
t$type, "||",
ifelse(is.na(t$actions), "", t$actions)
)
dup_exact <- duplicated(key_exact) | duplicated(key_exact, fromLast = TRUE)
if (any(dup_exact)) {
bad <- t[dup_exact, c("feature", "type", "actions", "target_value"), drop = FALSE]
ex <- utils::head(
paste0(
"(feature=", bad$feature,
", type='", bad$type,
"', actions='", ifelse(is.na(bad$actions) | !nzchar(bad$actions), "ALL", bad$actions),
"', target_value=", bad$target_value, ")"
),
8
)
stop(
"Multiple targets were defined for the same (feature, type, actions) combination.\n",
"This is ambiguous and is not allowed.\n",
"Examples: ", paste(ex, collapse = ", "),
if (nrow(bad) > 8) paste0(" ... (", nrow(bad), " rows)") else "",
call. = FALSE
)
}
# ------------------------------------------------------------------
# 2) same (feature, actions) with different type: allowed, but warn
# ------------------------------------------------------------------
key_feature_actions <- paste0(
t$feature, "||",
ifelse(is.na(t$actions), "", t$actions)
)
split_fa <- split(t$type, key_feature_actions, drop = TRUE)
multi_type_keys <- names(split_fa)[vapply(split_fa, function(z) length(unique(z)) > 1, logical(1))]
if (length(multi_type_keys) > 0) {
ex_keys <- utils::head(multi_type_keys, 8)
warning(
"Multiple targets were defined for the same (feature, actions) combination with different target types.\n",
"They will be applied as separate constraints, and the strongest one may dominate in practice.\n",
"Examples: ", paste(ex_keys, collapse = ", "),
if (length(multi_type_keys) > 8) paste0(" ... (", length(multi_type_keys), " combinations)") else "",
call. = FALSE
)
}
# ------------------------------------------------------------------
# 3) drop near-zero targets
# ------------------------------------------------------------------
idx_zero <- is.finite(t$target_value) & abs(t$target_value) <= zero_tol
if (any(idx_zero)) {
z <- t[idx_zero, , drop = FALSE]
warning(
"Skipping ", nrow(z), " target(s) with target_value ~ 0 (|rhs| <= ", format(zero_tol), "). ",
"They are redundant and can obscure infeasibility diagnostics.",
call. = FALSE
)
t <- t[!idx_zero, , drop = FALSE]
}
if (nrow(t) == 0) {
x$data$model_args$targets_applied <- TRUE
x$data$model_args$targets_counts <- list(actions = 0L)
return(invisible(x))
}
op <- x$data$model_ptr
.mk_targets_df <- function(features, values, colname) {
df <- data.frame(internal_id = as.integer(features), stringsAsFactors = FALSE)
df[[colname]] <- as.numeric(values)
df
}
.check_feature_present_in_df <- function(features, df, feature_col, what) {
features <- as.integer(features)
if (length(features) == 0) return(invisible(TRUE))
present <- unique(as.integer(df[[feature_col]]))
miss <- features[!features %in% present]
if (length(miss) > 0) {
ex <- paste(utils::head(sort(unique(miss)), 8), collapse = ", ")
stop(
"Infeasible targets detected: some features in ", what, " targets have no contributions in the model tables.\n",
"Missing feature ids: ", ex,
if (length(unique(miss)) > 8) paste0(" ... (", length(unique(miss)), " total)") else "",
call. = FALSE
)
}
invisible(TRUE)
}
.filter_effects_by_actions <- function(de, actions_string) {
if (is.na(actions_string) || !nzchar(actions_string)) {
return(de)
}
actions_vals <- strsplit(actions_string, "\\|")[[1]]
actions_vals <- unique(actions_vals[nzchar(actions_vals)])
matched <- .pa_resolve_action_subset(x, actions_vals)
keep_internal <- as.integer(matched$internal_id)
de[de$internal_action %in% keep_internal, , drop = FALSE]
}
if (.pa_uses_aggregate_effects(x)) {
return(invisible(.pa_apply_aggregate_targets(x, t)))
}
dbm <- .get_dist_benefit_model_from_effects(x, benefit_col = "amount_after")
if (is.null(dbm) || nrow(dbm) == 0) {
stop(
"Targets present but no action feature contributions are available in dist_effects. ",
"Run add_effects() first and make sure dist_effects contains 'amount_after'.",
call. = FALSE
)
}
if (!("feature" %in% names(dbm))) {
stop("dist_benefit_data must contain a 'feature' column for validation.", call. = FALSE)
}
if (!exists("rcpp_add_target_recovery", mode = "function")) {
stop("Missing rcpp_add_target_recovery() in the package.", call. = FALSE)
}
# ------------------------------------------------------------------
# 4) Map external feature ids in targets to internal feature ids
# ------------------------------------------------------------------
feature_map <- x$data$features[, c("id", "internal_id"), drop = FALSE]
feature_map$id <- as.integer(feature_map$id)
feature_map$internal_id <- as.integer(feature_map$internal_id)
t$internal_feature <- feature_map$internal_id[
match(as.integer(t$feature), feature_map$id)
]
if (anyNA(t$internal_feature)) {
missing_features <- unique(t$feature[is.na(t$internal_feature)])
stop(
"Some target features could not be mapped to internal feature ids: ",
paste(missing_features, collapse = ", "),
".",
call. = FALSE
)
}
# ------------------------------------------------------------------
# 5) Apply each row as a separate constraint
# ------------------------------------------------------------------
n_applied <- 0L
for (ii in seq_len(nrow(t))) {
tt <- t[ii, , drop = FALSE]
actions_string <- tt$actions[1]
dbm_sub <- .filter_effects_by_actions(dbm, actions_string)
if (nrow(dbm_sub) == 0) {
actions_lab <- if (is.na(actions_string) || !nzchar(actions_string)) {
"ALL actions"
} else {
actions_string
}
stop(
"Target for feature ", tt$feature[1],
" and actions subset '", actions_lab,
"' cannot be applied because no matching effect rows remain after filtering.",
call. = FALSE
)
}
.check_feature_present_in_df(
tt$internal_feature,
dbm_sub,
"internal_feature",
what = "actions"
)
rcpp_add_target_recovery(
op,
features_data = .mk_targets_df(
tt$internal_feature,
tt$target_value,
"target_actions"
),
dist_actions_data = x$data$dist_actions_model,
dist_benefit_data = dbm_sub,
target_col = "target_actions"
)
n_applied <- n_applied + 1L
}
x$data$model_args$targets_applied <- TRUE
x$data$model_args$targets_counts <- list(actions = n_applied)
invisible(x)
}
# -------------------------------------------------------------------------
# Internal helpers MATHEMATICAL MODEL
# -------------------------------------------------------------------------
.pa_refresh_model_snapshot <- function(x, drop_triplets = TRUE) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_ptr)) return(x)
if (!requireNamespace("Matrix", quietly = TRUE)) {
stop("Package 'Matrix' is required to build sparse constraint matrix.", call. = FALSE)
}
model_list <- rcpp_optimization_problem_as_list(x$data$model_ptr)
# Build sparse A defensively (A_i/A_j are 0-based in C++ -> +1 in R)
if (all(c("A_i", "A_j", "A_x") %in% names(model_list)) &&
length(model_list$A_i) == length(model_list$A_j) &&
length(model_list$A_i) == length(model_list$A_x)) {
model_list$A <- Matrix::sparseMatrix(
i = as.integer(model_list$A_i) + 1L,
j = as.integer(model_list$A_j) + 1L,
x = as.numeric(model_list$A_x),
dims = c(length(model_list$rhs), length(model_list$obj))
)
if (isTRUE(drop_triplets)) {
model_list$A_i <- NULL
model_list$A_j <- NULL
model_list$A_x <- NULL
}
} else {
# fallback: empty sparse matrix if missing triplets
n_con <- if (!is.null(model_list$rhs)) length(model_list$rhs) else 0L
n_var <- if (!is.null(model_list$obj)) length(model_list$obj) else 0L
model_list$A <- Matrix::sparseMatrix(
i = integer(0), j = integer(0), x = numeric(0),
dims = c(n_con, n_var)
)
}
# Keep args attached if you use them downstream (optional but handy)
model_list$args <- x$data$model_args %||% list()
x$data$model_list <- model_list
# Optional: store dims for fast printing
x$data$model_args <- x$data$model_args %||% list()
x$data$model_args$n_constraints <- if (!is.null(model_list$rhs)) length(model_list$rhs) else NA_integer_
x$data$model_args$n_variables <- if (!is.null(model_list$obj)) length(model_list$obj) else NA_integer_
x$data$model_args$nnz <- Matrix::nnzero(model_list$A)
x
}
# .pa_apply_action_max_per_pu_if_present <- function(x) {
# stopifnot(inherits(x, "Problem"))
#
# spec <- x$data$constraints$action_max_per_pu %||% NULL
# if (is.null(spec)) return(invisible(x))
#
# if (is.null(x$data$model_ptr)) {
# stop("No active model pointer found in x$data$model_ptr.", call. = FALSE)
# }
#
# if (!exists("rcpp_add_action_max_per_pu", mode = "function")) {
# stop("Missing rcpp_add_action_max_per_pu() in the package.", call. = FALSE)
# }
#
# da <- x$data$dist_actions_model
# if (is.null(da) || !inherits(da, "data.frame") || nrow(da) == 0) {
# stop("action_max_per_pu requires non-empty x$data$dist_actions_model.", call. = FALSE)
# }
#
# # defensive: required columns
# need <- c("internal_pu", "internal_action", "internal_row")
# miss <- setdiff(need, names(da))
# if (length(miss) > 0) {
# stop("dist_actions_model must contain columns: ", paste(miss, collapse = ", "), call. = FALSE)
# }
#
# maxv <- as.integer(spec$max %||% 1L)
# if (!is.finite(maxv) || is.na(maxv) || maxv < 0L) stop("Invalid max in action_max_per_pu.", call. = FALSE)
#
# # Convert external ids -> internal ids
# pu_ext <- spec$pu %||% x$data$pu$id
# pu_ext <- as.integer(pu_ext)
# pu_map <- x$data$pu[, c("id","internal_id")]
# pu_int <- pu_map$internal_id[match(pu_ext, pu_map$id)]
# pu_int <- pu_int[!is.na(pu_int)]
# if (length(pu_int) == 0) stop("action_max_per_pu: no valid PUs after mapping to internal ids.", call. = FALSE)
#
# act_ext <- spec$actions %||% x$data$actions$id
# act_ext <- as.character(act_ext)
# act_map <- x$data$actions[, c("id","internal_id")]
# act_int <- act_map$internal_id[match(act_ext, act_map$id)]
# act_int <- act_int[!is.na(act_int)]
# if (length(act_int) == 0) stop("action_max_per_pu: no valid actions after mapping to internal ids.", call. = FALSE)
#
# # call C++
# res <- rcpp_add_action_max_per_pu(
# x = x$data$model_ptr,
# dist_actions_data = da,
# max_per_pu = maxv,
# internal_pu_ids = as.integer(pu_int),
# internal_action_ids = as.integer(act_int)
# )
#
# # optional registry
# x$data$model_registry <- x$data$model_registry %||% list(cons = list(), vars = list(), obj_templates = list(), objective = list())
# x$data$model_registry$cons$action_max_per_pu <- res
#
# invisible(x)
# }
.pa_apply_area_constraints_if_present <- function(x) {
stopifnot(inherits(x, "Problem"))
.area_unit_convert_from_m2 <- function(area_m2, unit) {
unit <- match.arg(unit, c("m2", "ha", "km2"))
switch(
unit,
m2 = area_m2,
ha = area_m2 / 1e4,
km2 = area_m2 / 1e6
)
}
.is_missing_actions <- function(actions_txt) {
length(actions_txt) == 0L ||
is.na(actions_txt) ||
!nzchar(trimws(actions_txt)) ||
identical(trimws(actions_txt), "NA")
}
cons <- x$data$constraints %||% list()
if (length(cons) == 0L) return(x)
specs <- cons$area %||% NULL
if (is.null(specs)) return(x)
if (is.null(x$data$model_ptr)) {
stop("Model pointer is missing while applying area constraints.", call. = FALSE)
}
x <- .pa_refresh_model_snapshot(x)
ml <- x$data$model_list
if (is.null(ml)) {
stop("Model snapshot is missing while applying area constraints.", call. = FALSE)
}
n_pu <- as.integer(ml$n_pu %||% 0L)
if (n_pu <= 0L) {
stop("Model has n_pu=0; cannot apply area constraints.", call. = FALSE)
}
if (!is.data.frame(specs)) {
stop(
"Stored area constraints must be a data.frame.",
call. = FALSE
)
}
required_cols <- c(
"type", "sense", "value", "tolerance",
"unit", "area_col", "actions", "name"
)
miss <- setdiff(required_cols, names(specs))
if (length(miss) > 0) {
stop(
"Stored area constraints are malformed. Missing columns: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
w0 <- as.integer(ml$w_offset %||% 0L)
x0 <- as.integer(ml$x_offset %||% 0L)
j0_w <- w0 + (0:(n_pu - 1L))
da <- x$data$dist_actions_model %||% NULL
for (k in seq_len(nrow(specs))) {
spec <- specs[k, , drop = FALSE]
sense <- as.character(spec$sense)[1]
rhs <- as.numeric(spec$value)[1]
tol <- as.numeric(spec$tolerance)[1]
nm <- as.character(spec$name)[1]
area_col <- as.character(spec$area_col)[1]
area_unit <- as.character(spec$unit)[1]
actions_txt <- as.character(spec$actions)[1]
if (!sense %in% c("min", "max", "equal")) {
stop("Unknown area constraint sense: ", sense, call. = FALSE)
}
if (!area_unit %in% c("m2", "ha", "km2")) {
stop("Unknown area constraint unit: ", area_unit, call. = FALSE)
}
if (!is.finite(rhs) || is.na(rhs) || rhs < 0) {
stop("Invalid area constraint value in stored area constraints.", call. = FALSE)
}
if (!is.finite(tol) || is.na(tol) || tol < 0) {
stop("Invalid area constraint tolerance in stored area constraints.", call. = FALSE)
}
if (is.na(nm) || !nzchar(nm)) {
stop("Stored area constraint has invalid `name`.", call. = FALSE)
}
area_col_arg <- if (is.na(area_col) || !nzchar(area_col)) {
NULL
} else {
area_col
}
# ------------------------------------------------------------
# Case 1: actions = NULL
# Area of selected planning units: sum_i area_i * w_i
# ------------------------------------------------------------
if (.is_missing_actions(actions_txt)) {
a <- .pa_get_area_vec(
x,
area_col = area_col_arg,
area_unit = area_unit
)
if (length(a) != n_pu) {
stop(
"Area vector length (", length(a), ") != n_pu (", n_pu,
") while applying area constraint `", nm, "`.",
call. = FALSE
)
}
var_index <- j0_w
coeff <- as.numeric(a)
# ------------------------------------------------------------
# Case 2: actions != NULL
# Effective action area: sum_ia action_area_ia * x_ia
# ------------------------------------------------------------
} else {
if (is.null(da) || !is.data.frame(da) || nrow(da) == 0L) {
stop(
"Area constraints with `actions` require `x$data$dist_actions_model`.",
call. = FALSE
)
}
required_da_cols <- c(
"action",
"internal_row",
"internal_pu",
"action_area"
)
miss_da <- setdiff(required_da_cols, names(da))
if (length(miss_da) > 0L) {
stop(
"`dist_actions_model` must contain columns: ",
paste(miss_da, collapse = ", "),
".",
call. = FALSE
)
}
actions_chr <- strsplit(actions_txt, "\\|", fixed = FALSE)[[1]]
actions_chr <- trimws(actions_chr)
actions_chr <- actions_chr[
!is.na(actions_chr) &
nzchar(actions_chr) &
actions_chr != "NA"
]
act_subset <- .pa_resolve_action_subset(x, subset = actions_chr)
if (!is.data.frame(act_subset) || nrow(act_subset) == 0L) {
stop(
"Stored area constraint `", nm,
"` refers to an invalid or empty action subset.",
call. = FALSE
)
}
keep <- da$action %in% act_subset$id
if (!any(keep)) {
stop(
"Stored area constraint `", nm,
"` does not match any rows in `dist_actions_model`.",
call. = FALSE
)
}
da_sub <- da[keep, , drop = FALSE]
action_area_m2 <- as.numeric(da_sub$action_area)
missing_area <- is.na(action_area_m2)
if (any(missing_area)) {
pu_area_m2 <- tryCatch(
.pa_get_area_vec(
x,
area_col = area_col_arg,
area_unit = "m2"
),
error = function(e) NULL
)
if (!is.null(pu_area_m2)) {
names(pu_area_m2) <- as.character(x$data$pu$id)
action_area_m2[missing_area] <- as.numeric(
pu_area_m2[as.character(da_sub$pu[missing_area])]
)
}
}
if (
anyNA(action_area_m2) ||
any(!is.finite(action_area_m2))
) {
stop(
"Area constraint `", nm, "` uses `actions`, so it requires finite ",
"`action_area` values for all relevant feasible (pu, action) pairs. ",
"Provide `action_area` in add_actions(), use spatial include_pairs, ",
"or provide usable planning-unit areas through `area_col` or problem geometry.",
call. = FALSE
)
}
if (any(action_area_m2 < 0)) {
stop(
"`action_area` values used in area constraint `", nm,
"` must be non-negative.",
call. = FALSE
)
}
var_index <- x0 + (as.integer(da_sub$internal_row) - 1L)
coeff <- .area_unit_convert_from_m2(
action_area_m2,
area_unit
)
if (length(var_index) != length(coeff) || length(coeff) == 0L) {
stop(
"Failed to assemble coefficients for area constraint `", nm, "`.",
call. = FALSE
)
}
}
if (identical(sense, "min")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs,
name = nm,
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
} else if (identical(sense, "max")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs,
name = nm,
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
} else if (identical(sense, "equal")) {
if (tol == 0) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "==",
rhs = rhs,
name = nm,
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
} else {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs - tol,
name = paste0(nm, "_lower"),
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs + tol,
name = paste0(nm, "_upper"),
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
}
}
}
x
}
.pa_cbc_complete_dimensions <- function(mat, row_lb, row_ub, col_lb, col_ub) {
# rcbc passes sparse triplets, rather than matrix dimensions, to CBC.
# Its native matrix therefore loses trailing empty rows/columns. One
# redundant bound row records both dimensions without deleting variables
# or changing their bounds, objective contributions, or returned indices.
nr <- nrow(mat)
nc <- ncol(mat)
if (nc > 0L && (nr == 0L ||
!any(mat[nr, , drop = FALSE] != 0) ||
!any(mat[, nc, drop = FALSE] != 0))) {
anchor <- Matrix::sparseMatrix(i = 1L, j = nc, x = 1, dims = c(1L, nc))
mat <- rbind(mat, anchor)
row_lb <- c(row_lb, col_lb[nc])
row_ub <- c(row_ub, col_ub[nc])
}
list(mat = mat, row_lb = row_lb, row_ub = row_ub)
}
.pa_positive_objective_scale <- function(obj) {
nonzero <- abs(obj[is.finite(obj) & obj != 0])
if (!length(nonzero)) return(1)
# A common positive factor preserves the scalar criterion exactly. Raise
# small rewards above solver tolerances without producing huge coefficients.
exponent <- max(0, min(6, ceiling(-log10(min(nonzero))),
floor(log10(1e8 / max(nonzero)))))
10^exponent
}
.pa_model_from_ptr <- function(op, args = list(), drop_triplets = TRUE) {
if (!requireNamespace("Matrix", quietly = TRUE)) {
stop("Package 'Matrix' is required to build sparse constraint matrix.", call. = FALSE)
}
model_list <- rcpp_optimization_problem_as_list(op)
# n_con / n_var siempre desde rhs/obj
n_con <- if (!is.null(model_list$rhs)) length(model_list$rhs) else 0L
n_var <- if (!is.null(model_list$obj)) length(model_list$obj) else 0L
# build sparse A defensively (A_i/A_j are 0-based -> +1)
if (all(c("A_i", "A_j", "A_x") %in% names(model_list)) &&
length(model_list$A_i) == length(model_list$A_j) &&
length(model_list$A_i) == length(model_list$A_x) &&
length(model_list$A_i) > 0L) {
model_list$A <- Matrix::sparseMatrix(
i = as.integer(model_list$A_i) + 1L,
j = as.integer(model_list$A_j) + 1L,
x = as.numeric(model_list$A_x),
dims = c(n_con, n_var) # <<< CRÍTICO: fija dimensiones reales
)
if (isTRUE(drop_triplets)) {
model_list$A_i <- NULL
model_list$A_j <- NULL
model_list$A_x <- NULL
}
} else {
model_list$A <- Matrix::sparseMatrix(
i = integer(0), j = integer(0), x = numeric(0),
dims = c(n_con, n_var)
)
}
# attach model args (needed for curve/segments and any other solver params)
model_list$args <- args %||% list()
# registry: ya viene desde C++ como data.frame en model_list$registry.
# No lo toques aquí; solo asegúrate de no borrarlo por error.
# (si quisieras, podrías validar que exista)
# if (is.null(model_list$registry)) model_list$registry <- data.frame()
model_list
}
# -------------------------------------------------------------------------
# Internal helpers CLASS
# -------------------------------------------------------------------------
.pa_cli_theme <- function() {
list(
.h = list("font-weight" = "bold", color = "#569746"),
.cls = list("font-weight" = "bold", color = "#4C78A8"),
.code = list(color = "#3A7D44"),
.muted = list(color = "grey60"),
.ok = list(color = "#569746", "font-weight" = "bold"),
.warn = list(color = "#C78A00", "font-weight" = "bold"),
.bad = list(color = "#C0392B", "font-weight" = "bold")
)
}
.pa_cli_box_chars <- function() {
use_unicode <- l10n_info()[["UTF-8"]]
if (isTRUE(use_unicode)) {
list(
j = "\u251C", # ├
l = "\u2514", # └
v = "\u2502", # │
b = "\u2500" # ─
)
} else {
list(
j = "+",
l = "\\",
v = "|",
b = "-"
)
}
}
.pa_safe_range <- function(x, digits = 5) {
x <- as.numeric(x)
x <- x[is.finite(x) & !is.na(x)]
if (length(x) == 0) return(NULL)
base::round(range(x), digits)
}
# .pa_repr_atomic <- function(x, label = NULL, max_items = 6) {
# x <- as.character(x)
# x <- x[!is.na(x) & nzchar(x)]
# if (length(x) == 0) {
# if (is.null(label)) return("{.muted (none)}")
# return(paste0("{.muted (0 ", label, ")}"))
# }
# if (length(x) <= max_items) {
# paste0(paste0('"', x, '"', collapse = ", "))
# } else {
# head <- x[seq_len(max_items)]
# paste0(
# paste0('"', head, '"', collapse = ", "),
# ", {.muted ... (", length(x), " total)}"
# )
# }
# }
.pa_get_cost_vec <- function(pu) {
if (is.null(pu) || nrow(pu) == 0) return(numeric(0))
if ("cost" %in% names(pu)) return(as.numeric(pu$cost))
if ("monitoring_cost" %in% names(pu)) return(as.numeric(pu$monitoring_cost))
numeric(0)
}
.pa_get_action_cost_vec <- function(self) {
# new field (preferred)
if (!is.null(self$data$dist_actions) &&
inherits(self$data$dist_actions, "data.frame") &&
nrow(self$data$dist_actions) > 0 &&
"cost" %in% names(self$data$dist_actions)) {
return(as.numeric(self$data$dist_actions$cost))
}
numeric(0)
}
.pa_nrow0 <- function(x) {
if (is.null(x)) return(0L)
if (!inherits(x, "data.frame")) return(0L)
nrow(x)
}
.pa_has_model <- function(self) {
!is.null(self$data$model_list) && is.list(self$data$model_list)
}
.pa_model_dims <- function(self) {
# Returns list(n_con, n_var, nnz) safely
ml <- self$data$model_list
# If model_list doesn't exist yet, return zeros
if (is.null(ml) || !is.list(ml)) {
return(list(n_con = 0L, n_var = 0L, nnz = 0L))
}
# Best effort: support both A (dgCMatrix) and triplet (A_i/A_j/A_x)
n_con <- 0L
n_var <- 0L
nnz <- 0L
if (!is.null(ml$A) && inherits(ml$A, "Matrix")) {
n_con <- nrow(ml$A)
n_var <- ncol(ml$A)
nnz <- length(ml$A@x)
return(list(n_con = as.integer(n_con), n_var = as.integer(n_var), nnz = as.integer(nnz)))
}
if (!is.null(ml$A_i) && !is.null(ml$A_j)) {
# We may not know nrow/ncol if not stored; infer n_con/n_var if present
nnz <- length(ml$A_i)
if (!is.null(ml$rhs)) n_con <- length(ml$rhs)
if (!is.null(ml$obj)) n_var <- length(ml$obj)
return(list(n_con = as.integer(n_con), n_var = as.integer(n_var), nnz = as.integer(nnz)))
}
# Fallback from rhs/obj if present
if (!is.null(ml$rhs)) n_con <- length(ml$rhs)
if (!is.null(ml$obj)) n_var <- length(ml$obj)
list(n_con = as.integer(n_con), n_var = as.integer(n_var), nnz = as.integer(nnz))
}
# .pa_model_blocks <- function(self) {
# # Returns list(n_w, n_x, n_z) if index mapping exists; otherwise NULL.
# # This expects you to store something like idx from rcpp_add_base_variables()
# # in self$data$model_index. Your idx currently returns w_index/x_index and
# # could also return z_index (recommended).
# idx <- self$data$model_index
# if (is.null(idx) || !is.list(idx)) return(NULL)
#
# n_w <- if (!is.null(idx$w_index)) length(idx$w_index) else NA_integer_
# n_x <- if (!is.null(idx$x_index)) length(idx$x_index) else NA_integer_
# n_z <- if (!is.null(idx$z_index)) length(idx$z_index) else NA_integer_
#
# # if none exist, don't print a misleading line
# if (is.na(n_w) && is.na(n_x) && is.na(n_z)) return(NULL)
#
# list(
# n_w = ifelse(is.na(n_w), 0L, as.integer(n_w)),
# n_x = ifelse(is.na(n_x), 0L, as.integer(n_x)),
# n_z = ifelse(is.na(n_z), 0L, as.integer(n_z))
# )
# }
# .pa_model_args <- function(self) {
# # Return a standardized args list if present; otherwise NULL
# a <- self$data$model_args
# if (is.null(a) || !is.list(a)) return(NULL)
#
# # Standardize expected fields (do not error if missing)
# out <- list(
# model_type = if (!is.null(a$model_type)) a$model_type else NA_character_,
# modelsense = if (!is.null(a$modelsense)) a$modelsense else NA_character_,
# objective_id = if (!is.null(a$objective_id)) a$objective_id else NA_character_,
# budget = if (!is.null(a$budget)) a$budget else NA_real_,
# blm = if (!is.null(a$blm)) a$blm else NA_real_,
# benefit_exponent = if (!is.null(a$benefit_exponent)) a$benefit_exponent else NA_integer_,
# curve_segments = if (!is.null(a$curve_segments)) a$curve_segments else NA_integer_
# )
#
# out
# }
# -------------------------------------------------------------------------
# Internal helpers DATA
# -------------------------------------------------------------------------
`%||%` <- function(a, b) if (is.null(a)) b else a
# internal helper: detect tabular vs spatial vs invalid mixes
# .pa_detect_input_mode <- function(pu, features, dist_features) {
#
# # ---- local helpers (NO imports; only type checks)
# .is_df <- function(x) inherits(x, "data.frame")
#
# .is_spatraster <- function(x) inherits(x, "SpatRaster")
# .is_spatvector <- function(x) inherits(x, "SpatVector")
# .is_sf <- function(x) inherits(x, "sf")
#
# .is_raster_path <- function(x) {
# is.character(x) && length(x) == 1L &&
# grepl("\\.(tif|tiff|grd|asc|nc)$", tolower(x))
# }
#
# .is_vector_path <- function(x) {
# is.character(x) && length(x) == 1L &&
# grepl("\\.(shp|gpkg|geojson|json|fgb)$", tolower(x))
# }
#
# .is_spatial_pu <- function(x) .is_spatraster(x) || .is_spatvector(x) || .is_sf(x) || .is_raster_path(x) || .is_vector_path(x)
# .is_spatial_features <- function(x) .is_spatraster(x) || .is_raster_path(x)
#
# dist_missing <- missing(dist_features) || is.null(dist_features)
#
# # ------------------------------------------------------------
# # Rule 1: If dist_features is provided as data.frame -> TABULAR
# # ------------------------------------------------------------
# if (!dist_missing) {
# if (!.is_df(dist_features)) {
# stop("`dist_features` must be a data.frame in tabular mode, or NULL/missing in spatial mode.", call. = FALSE)
# }
#
# # dist_features df => require pu + features df (avoid ambiguity)
# if (!.is_df(pu)) {
# stop("Tabular mode detected because `dist_features` is a data.frame, but `pu` is not a data.frame.", call. = FALSE)
# }
# if (!.is_df(features)) {
# stop("Tabular mode detected because `dist_features` is a data.frame, but `features` is not a data.frame.", call. = FALSE)
# }
#
# return(list(mode = "tabular"))
# }
#
# # ------------------------------------------------------------
# # Rule 2: dist_features missing/NULL -> could be SPATIAL or invalid
# # ------------------------------------------------------------
# # spatial mode requires at least one spatial-ish input
# if (.is_spatial_features(features) || .is_spatial_pu(pu)) {
# return(list(mode = "spatial"))
# }
#
# # dist_features missing + no spatial inputs -> invalid (user forgot dist_features)
# stop(
# "Could not determine input style. Provide tabular inputs (data.frames: `pu`, `features`, `dist_features`) ",
# "or spatial inputs (e.g., `pu` and/or `features` as rasters/vectors/paths) with `dist_features = NULL`.",
# call. = FALSE
# )
# }
# helpers
# .read_rast <- function(x) {
# if (is.null(x)) return(NULL)
# if (inherits(x, "SpatRaster")) return(x)
# if (is.character(x)) return(terra::rast(x))
# stop("Unsupported raster input.", call. = FALSE)
# }
# .read_vect <- function(x) {
# if (is.null(x)) return(NULL)
# if (inherits(x, "SpatVector")) return(x)
# if (inherits(x, "sf")) return(terra::vect(x))
# if (is.character(x)) return(terra::vect(x))
# stop("Unsupported vector input.", call. = FALSE)
# }
.is_raster_path <- function(x) {
is.character(x) && grepl("\\.(tif|tiff|grd|asc|nc)$", tolower(x))
}
# .fun_from_name <- function(name) {
# switch(
# name,
# mean = function(v, ...) mean(v, na.rm = TRUE),
# sum = function(v, ...) sum(v, na.rm = TRUE),
# stop("Unknown aggregation function: ", name, call. = FALSE)
# )
# }
.pa_has_coords <- function(x) {
is.list(x$data) && !is.null(x$data$pu_coords) &&
inherits(x$data$pu_coords, "data.frame") &&
all(c("id","x","y") %in% names(x$data$pu_coords)) &&
nrow(x$data$pu_coords) > 0
}
.pa_spatial_relations_summary <- function(x) {
rels <- x$data$spatial_relations
if (is.null(rels) || !is.list(rels) || length(rels) == 0) return(NULL)
nm <- names(rels)
if (is.null(nm)) nm <- rep("", length(rels))
nm[nm == ""] <- paste0("rel_", seq_along(nm))
out <- lapply(seq_along(rels), function(i) {
r <- rels[[i]]
if (!inherits(r, "data.frame") || nrow(r) == 0) {
return(data.frame(name = nm[i], edges = 0L, w_min = NA_real_, w_max = NA_real_))
}
w <- suppressWarnings(as.numeric(r$weight))
rng <- .pa_safe_range(w)
data.frame(
name = nm[i],
edges = as.integer(nrow(r)),
w_min = if (is.null(rng)) NA_real_ else rng[[1]],
w_max = if (is.null(rng)) NA_real_ else rng[[2]]
)
})
do.call(rbind, out)
}
# -------------------------------------------------------------------------
# Internal helpers SOLVER
# -------------------------------------------------------------------------
.pa_get_solve_args <- function(x,
solver = NULL,
gap_limit = NULL,
time_limit = NULL,
solution_limit = NULL,
cores = NULL,
verbose = NULL,
name_output_file = NULL,
output_file = NULL,
solver_params = NULL) {
stopifnot(inherits(x, "Problem"))
defaults <- list(
solver = "auto",
gap_limit = 0.0,
time_limit = .Machine$integer.max,
solution_limit = FALSE,
cores = NULL,
verbose = FALSE,
name_output_file = NULL,
output_file = FALSE,
solver_params = list()
)
stored <- x$data$solve_args %||% list()
if (!is.list(stored)) stored <- list()
out <- utils::modifyList(defaults, stored)
# ---- explicit overrides (optional)
if (!is.null(gap_limit)) out$gap_limit <- gap_limit
if (!is.null(time_limit)) out$time_limit <- time_limit
if (!is.null(solution_limit)) out$solution_limit <- solution_limit
if (!is.null(cores)) out$cores <- cores
if (!is.null(verbose)) out$verbose <- verbose
if (!is.null(name_output_file)) out$name_output_file <- name_output_file
if (!is.null(output_file)) out$output_file <- output_file
# solver override (NULL = not specified)
if (!is.null(solver)) {
solver <- as.character(solver)[1]
if (!identical(solver, "")) out$solver <- solver
}
# solver_params override/merge
if (!is.null(solver_params)) {
if (!is.list(solver_params)) stop("solver_params must be a list.", call. = FALSE)
out$solver_params <- utils::modifyList(out$solver_params %||% list(), solver_params)
}
# ---- normalize
out$solver <- as.character(out$solver)[1]
if (!out$solver %in% c("auto", "gurobi", "cplex", "cbc", "symphony")) {
stop("Unknown solver in x$data$solve_args$solver: ", out$solver,
". Use one of: auto, gurobi, cplex, cbc, symphony.", call. = FALSE)
}
out$gap_limit <- as.numeric(out$gap_limit)
if (!is.finite(out$gap_limit) || out$gap_limit < 0 || out$gap_limit > 1) {
stop("gap_limit must be a finite number in [0, 1].", call. = FALSE)
}
out$time_limit <- round(as.numeric(out$time_limit), 3)
if (!is.finite(out$time_limit) || out$time_limit < 0) {
stop("time_limit must be a finite number >= 0.", call. = FALSE)
}
if (!is.null(out$cores)) {
out$cores <- as.integer(out$cores)
if (length(out$cores) != 1L || !is.finite(out$cores) || out$cores < 1) {
stop("cores must be an integer >= 1.", call. = FALSE)
}
# cap cores defensively (avoid hard error inside solve)
max_cores <- parallel::detectCores(TRUE)
if (length(max_cores) == 1L && is.finite(max_cores) && out$cores > max_cores) {
out$cores <- as.integer(max_cores)
}
}
out$solution_limit <- isTRUE(out$solution_limit)
out$verbose <- isTRUE(out$verbose)
out$output_file <- isTRUE(out$output_file)
if (!is.null(out$name_output_file)) {
out$name_output_file <- as.character(out$name_output_file)[1]
if (is.na(out$name_output_file) || !nzchar(out$name_output_file)) {
out$name_output_file <- NULL
}
}
if (is.null(out$solver_params) || !is.list(out$solver_params)) out$solver_params <- list()
out
}
# Report and neutralize common settings that are unavailable through a
# particular R solver interface. This also protects objects created with older
# multiscape versions, before capability checks were performed by set_solver().
.pa_apply_solver_capabilities <- function(solver,
cores,
solution_limit,
output_file,
name_output_file,
solver_params,
warn = TRUE) {
unsupported <- character(0)
solver_params <- solver_params %||% list()
if (identical(solver, "cplex")) {
if (!is.null(cores)) unsupported <- c(unsupported, "cores")
if (isTRUE(solution_limit)) unsupported <- c(unsupported, "solution_limit")
if (isTRUE(output_file) ||
(!is.null(name_output_file) && !identical(output_file, FALSE))) {
unsupported <- c(unsupported, "write_log/log_file")
}
rcplex_parameters <- c(
"trace", "method", "preind", "aggind", "itlim", "epagap", "epgap",
"tilim", "disjcuts", "mipemphasis", "cliques", "nodesel", "probe",
"varsel", "flowcovers", "solnpoolagap", "solnpoolgap",
"solnpoolintensity", "maxcalls", "round"
)
unknown <- setdiff(names(solver_params), rcplex_parameters)
if (length(unknown) > 0L) {
unsupported <- c(
unsupported,
paste0("solver_params$", unknown)
)
solver_params[unknown] <- NULL
}
cores <- NULL
solution_limit <- FALSE
output_file <- FALSE
name_output_file <- NULL
}
if (identical(solver, "symphony")) {
if (!is.null(cores)) unsupported <- c(unsupported, "cores")
if (isTRUE(output_file) ||
(!is.null(name_output_file) && !identical(output_file, FALSE))) {
unsupported <- c(unsupported, "write_log/log_file")
}
if (length(solver_params) > 0L) {
unsupported <- c(unsupported, "solver_params")
}
cores <- NULL
output_file <- FALSE
name_output_file <- NULL
solver_params <- list()
}
if (identical(solver, "cbc")) {
if (!is.null(cores)) {
unsupported <- c(unsupported, "cores (thread control is not available through rcbc)")
cores <- NULL
}
if (isTRUE(output_file) ||
(!is.null(name_output_file) && !identical(output_file, FALSE))) {
unsupported <- c(unsupported, "write_log/log_file")
output_file <- FALSE
name_output_file <- NULL
}
}
unsupported <- unique(unsupported)
if (isTRUE(warn) && length(unsupported) > 0L) {
warning(
paste0(
"Parameter(s) not available for solver '", solver,
"' through its current R interface: ",
paste(unsupported, collapse = ", "),
". The unsupported setting(s) will be ignored."
),
call. = FALSE,
immediate. = TRUE
)
}
list(
cores = cores,
solution_limit = isTRUE(solution_limit),
output_file = isTRUE(output_file),
name_output_file = name_output_file,
solver_params = solver_params %||% list()
)
}
# -------------------------------------------------------------------------
# Internal helpers SOLUTIONS
# -------------------------------------------------------------------------
.pa_extract_solution_tables <- function(x, sol, threshold = 0.5) {
stopifnot(inherits(x, "Problem"))
stopifnot(is.numeric(sol))
# --- get model list (snapshot) or from ptr
ml <- x$data$model_list %||% NULL
if (is.null(ml)) {
stopifnot(!is.null(x$data$model_ptr))
ml <- rcpp_optimization_problem_as_list(x$data$model_ptr)
}
# --- fallbacks if model metadata missing
pu_df <- x$data$pu
da_df <- x$data$dist_actions_model %||% x$data$dist_actions
df_df <- x$data$dist_features
n_pu <- as.integer(ml$n_pu %||% nrow(pu_df) %||% 0L)
n_x <- as.integer(ml$n_x %||% (if (inherits(da_df, "data.frame")) nrow(da_df) else 0L))
n_z <- as.integer(ml$n_z %||% (if (inherits(df_df, "data.frame")) nrow(df_df) else 0L))
w_off <- as.integer(ml$w_offset %||% 0L)
x_off <- as.integer(ml$x_offset %||% 0L)
z_off <- as.integer(ml$z_offset %||% 0L)
slice_safe <- function(v, start1, end1) {
if (length(v) == 0) return(numeric(0))
if (is.na(start1) || is.na(end1) || start1 > end1) return(numeric(0))
end1 <- min(end1, length(v))
start1 <- min(max(1L, start1), end1)
v[start1:end1]
}
# --- slices
w <- if (n_pu > 0L) slice_safe(sol, w_off + 1L, w_off + n_pu) else numeric(0)
xv <- if (n_x > 0L) slice_safe(sol, x_off + 1L, x_off + n_x ) else numeric(0)
zv <- if (n_z > 0L) slice_safe(sol, z_off + 1L, z_off + n_z ) else numeric(0)
# -------------------------
# 1) PU selection table
# -------------------------
pu_out <- pu_df
if (!inherits(pu_out, "data.frame") || nrow(pu_out) == 0) {
pu_out <- data.frame()
} else {
if (length(w) != nrow(pu_out)) {
warning(
"Mismatch: nrow(pu) = ", nrow(pu_out),
" but length(w slice) = ", length(w),
". Setting pu$selected = NA.",
call. = FALSE
)
pu_out$selected <- rep(NA_integer_, nrow(pu_out))
} else {
pu_out$selected <- as.integer(w > threshold)
}
}
# -------------------------
# 2) Actions selection table
# -------------------------
da_out <- da_df
if (!inherits(da_out, "data.frame") || nrow(da_out) == 0) {
da_out <- data.frame()
} else {
if (length(xv) != nrow(da_out)) {
warning(
"Mismatch: nrow(dist_actions_model) = ", nrow(da_out),
" but length(x slice) = ", length(xv),
". Setting actions$selected = NA.",
call. = FALSE
)
da_out$selected <- rep(NA_integer_, nrow(da_out))
} else {
da_out$selected <- as.integer(xv > threshold)
}
if (all(c("internal_pu", "internal_action") %in% names(da_out))) {
key_da <- paste0(da_out$internal_pu, ":", da_out$internal_action)
if (anyDuplicated(key_da)) {
stop(
"dist_actions_model has duplicated (internal_pu, internal_action) pairs. ",
"This breaks mapping of effects->x. Fix upstream (ensure unique feasible pairs).",
call. = FALSE
)
}
}
}
# -------------------------
# 3) Features summary
# -------------------------
feats <- x$data$features
de <- x$data$dist_effects_model %||% x$data$dist_effects
# Baseline total in the full landscape.
# This is contextual information, not achieved amount.
baseline_by_feat <- data.frame(
internal_feature = integer(0),
baseline_total = numeric(0)
)
if (!is.null(df_df) &&
inherits(df_df, "data.frame") &&
nrow(df_df) > 0 &&
all(c("internal_feature", "amount") %in% names(df_df))) {
df2 <- df_df
df2$amount <- as.numeric(df2$amount)
baseline_by_feat <- stats::aggregate(
baseline_total ~ internal_feature,
data = data.frame(
internal_feature = as.integer(df2$internal_feature),
baseline_total = as.numeric(df2$amount)
),
FUN = sum
)
}
# Map action-solution values to effect rows.
de_with_x <- NULL
if (!is.null(de) &&
inherits(de, "data.frame") &&
nrow(de) > 0 &&
length(xv) > 0 &&
all(c("internal_pu", "internal_action", "internal_feature") %in% names(de)) &&
inherits(da_out, "data.frame") &&
nrow(da_out) > 0 &&
all(c("internal_pu", "internal_action") %in% names(da_out))) {
key_da <- paste0(da_out$internal_pu, ":", da_out$internal_action)
map <- stats::setNames(seq_len(nrow(da_out)), key_da)
key_de <- paste0(de$internal_pu, ":", de$internal_action)
xrow <- unname(map[key_de])
ok <- !is.na(xrow)
if (!all(ok)) {
warning(
sum(!ok),
" rows in dist_effects have no matching (pu, action) in dist_actions_model and were ignored.",
call. = FALSE
)
de <- de[ok, , drop = FALSE]
xrow <- xrow[ok]
}
ok2 <- xrow >= 1L & xrow <= length(xv)
if (!all(ok2)) {
warning(
sum(!ok2),
" mapped x rows fall outside the x slice (length(x) = ", length(xv), "); ignored.",
call. = FALSE
)
de <- de[ok2, , drop = FALSE]
xrow <- xrow[ok2]
}
de_with_x <- de
de_with_x$x_value <- as.numeric(xv[xrow])
if (!("benefit" %in% names(de_with_x))) de_with_x$benefit <- 0
if (!("loss" %in% names(de_with_x))) de_with_x$loss <- 0
if (!("amount_after" %in% names(de_with_x))) de_with_x$amount_after <- 0
de_with_x$benefit <- as.numeric(de_with_x$benefit)
de_with_x$loss <- as.numeric(de_with_x$loss)
de_with_x$amount_after <- as.numeric(de_with_x$amount_after)
de_with_x$benefit[is.na(de_with_x$benefit)] <- 0
de_with_x$loss[is.na(de_with_x$loss)] <- 0
de_with_x$amount_after[is.na(de_with_x$amount_after)] <- 0
# Selected effects.
de_with_x$selected_benefit <- de_with_x$benefit * de_with_x$x_value
de_with_x$selected_loss <- de_with_x$loss * de_with_x$x_value
de_with_x$selected_net <- de_with_x$selected_benefit - de_with_x$selected_loss
de_with_x$selected_amount_after <- de_with_x$amount_after * de_with_x$x_value
# Baseline amount in selected action rows.
# Since amount_after = baseline + net, then baseline = amount_after - net.
de_with_x$baseline_amount <- de_with_x$amount_after - (de_with_x$benefit - de_with_x$loss)
de_with_x$baseline_amount[is.na(de_with_x$baseline_amount)] <- 0
de_with_x$selected_baseline <- de_with_x$baseline_amount * de_with_x$x_value
}
if (.pa_uses_aggregate_effects(x)) de_with_x <- .pa_joint_selected_features(x, da_out)
# Aggregated selected quantities by feature.
selected_baseline_by_feat <- data.frame(
internal_feature = integer(0),
selected_baseline = numeric(0)
)
selected_amount_after_by_feat <- data.frame(
internal_feature = integer(0),
selected_amount_after = numeric(0)
)
selected_benefit_by_feat <- data.frame(
internal_feature = integer(0),
selected_benefit = numeric(0)
)
selected_loss_by_feat <- data.frame(
internal_feature = integer(0),
selected_loss = numeric(0)
)
selected_net_by_feat <- data.frame(
internal_feature = integer(0),
selected_net = numeric(0)
)
if (!is.null(de_with_x) && nrow(de_with_x) > 0) {
selected_baseline_by_feat <- stats::aggregate(
selected_baseline ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_baseline = as.numeric(de_with_x$selected_baseline)
),
FUN = sum
)
selected_amount_after_by_feat <- stats::aggregate(
selected_amount_after ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_amount_after = as.numeric(de_with_x$selected_amount_after)
),
FUN = sum
)
selected_benefit_by_feat <- stats::aggregate(
selected_benefit ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_benefit = as.numeric(de_with_x$selected_benefit)
),
FUN = sum
)
selected_loss_by_feat <- stats::aggregate(
selected_loss ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_loss = as.numeric(de_with_x$selected_loss)
),
FUN = sum
)
selected_net_by_feat <- stats::aggregate(
selected_net ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_net = as.numeric(de_with_x$selected_net)
),
FUN = sum
)
}
# Main feature table.
if (is.null(feats) || !inherits(feats, "data.frame") || nrow(feats) == 0) {
feat_tbl <- data.frame()
} else {
feat_tbl <- data.frame(
feature = as.integer(feats$internal_id),
feature_name = if ("name" %in% names(feats)) as.character(feats$name) else as.character(feats$id),
stringsAsFactors = FALSE
)
feat_tbl <- dplyr::left_join(
feat_tbl,
baseline_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_baseline_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_amount_after_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_benefit_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_loss_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_net_by_feat,
by = c("feature" = "internal_feature")
)
fill_zero_cols <- c(
"baseline_total",
"selected_baseline",
"selected_amount_after",
"selected_benefit",
"selected_loss",
"selected_net"
)
for (cc in fill_zero_cols) {
if (!cc %in% names(feat_tbl)) {
feat_tbl[[cc]] <- 0
}
feat_tbl[[cc]][is.na(feat_tbl[[cc]])] <- 0
}
feat_tbl$selected_fraction_of_baseline <- ifelse(
feat_tbl$baseline_total > 0,
feat_tbl$selected_amount_after / feat_tbl$baseline_total,
NA_real_
)
# Optional backwards-compatible aliases.
# You can remove these later if you want a cleaner output.
feat_tbl$total_available <- feat_tbl$baseline_total
feat_tbl$benefit <- feat_tbl$selected_benefit
feat_tbl$loss <- feat_tbl$selected_loss
feat_tbl$net <- feat_tbl$selected_net
feat_tbl$amount_after <- feat_tbl$selected_amount_after
# Do NOT compute:
# feat_tbl$total <- feat_tbl$total_available + feat_tbl$net
#
# That would imply that unselected units remain part of the achieved output,
# which is not the interpretation used here.
}
# -------------------------
# 4) Targets summary
# -------------------------
tgt <- x$data$targets
tgt_out <- NULL
if (inherits(tgt, "data.frame") &&
nrow(tgt) > 0 &&
all(c("feature", "type", "target_value") %in% names(tgt)) &&
inherits(feat_tbl, "data.frame") &&
nrow(feat_tbl) > 0) {
tgt2 <- tgt
tgt2$feature <- as.integer(tgt2$feature)
tgt2$type <- as.character(tgt2$type)
tgt2$target_value <- as.numeric(tgt2$target_value)
# Backward compatibility: old code used subset; newer code uses actions.
if (!("actions" %in% names(tgt2))) {
if ("subset" %in% names(tgt2)) {
tgt2$actions <- as.character(tgt2$subset)
} else {
tgt2$actions <- NA_character_
}
}
tgt2$actions <- as.character(tgt2$actions)
tgt2$achieved <- NA_real_
.achieved_for_actions <- function(feature_ids, actions_string) {
if (is.null(de_with_x) || nrow(de_with_x) == 0) {
return(stats::setNames(rep(0, length(feature_ids)), feature_ids))
}
dd <- de_with_x
if (!is.na(actions_string) && nzchar(actions_string)) {
matched <- .pa_resolve_action_subset(x, strsplit(actions_string, "\\|")[[1]])
keep_actions <- as.integer(matched$internal_id)
if (.pa_uses_aggregate_effects(x)) {
dd <- .pa_joint_selected_features(x, da_out, keep_actions)
} else {
dd <- dd[dd$internal_action %in% keep_actions, , drop = FALSE]
}
}
if (nrow(dd) == 0) {
return(stats::setNames(rep(0, length(feature_ids)), feature_ids))
}
tmp <- data.frame(
feature = as.integer(x$data$features$id[match(dd$internal_feature, x$data$features$internal_id)]),
achieved = as.numeric(dd$selected_amount_after)
)
agg <- stats::aggregate(achieved ~ feature, data = tmp, FUN = sum)
out <- stats::setNames(rep(0, length(feature_ids)), feature_ids)
hit <- match(feature_ids, agg$feature)
ok <- !is.na(hit)
out[ok] <- agg$achieved[hit[ok]]
out
}
split_key <- ifelse(is.na(tgt2$actions) | !nzchar(tgt2$actions), "__ALL__", tgt2$actions)
idx_split <- split(seq_len(nrow(tgt2)), split_key)
for (nm in names(idx_split)) {
ii <- idx_split[[nm]]
actions_string <- tgt2$actions[ii][1]
feats_i <- tgt2$feature[ii]
achieved_i <- .achieved_for_actions(feats_i, actions_string)
tgt2$achieved[ii] <- as.numeric(achieved_i[as.character(feats_i)])
}
tgt2$gap <- tgt2$achieved - tgt2$target_value
tgt_out <- tgt2
}
list(
pu = pu_out,
actions = da_out,
features = feat_tbl,
targets = tgt_out
)
}
# -------------------------------------------------------------------------
# Internal helpers AREAS
# -------------------------------------------------------------------------
.pa_get_area_vec <- function(x,
area_col = NULL,
area_unit = c("m2", "ha", "km2")) {
stopifnot(inherits(x, "Problem"))
area_unit <- match.arg(area_unit)
pu <- x$data$pu
if (is.null(pu) || !inherits(pu, "data.frame")) {
stop("x$data$pu is missing or is not a data.frame.", call. = FALSE)
}
n_pu <- nrow(pu)
if (n_pu <= 0L) {
stop(
"x$data$pu has zero rows; cannot retrieve planning unit areas.",
call. = FALSE
)
}
area <- NULL
area_source <- NULL
area_col_used <- NULL
# ---------------------------------------------------------
# helper: retrieve an area column from pu_data_raw aligned to x$data$pu$id
# ---------------------------------------------------------
get_raw_area <- function(col) {
raw <- x$data$pu_data_raw
if (is.null(raw) || !inherits(raw, "data.frame")) {
return(NULL)
}
if (!(col %in% names(raw))) {
return(NULL)
}
if (!("id" %in% names(raw))) {
stop(
"x$data$pu_data_raw is missing an 'id' column.",
call. = FALSE
)
}
raw_id <- as.integer(raw$id)
pu_id <- as.integer(pu$id)
if (anyNA(raw_id) || anyNA(pu_id)) {
stop(
"Could not coerce x$data$pu$id or x$data$pu_data_raw$id to integer ",
"while retrieving planning unit areas.",
call. = FALSE
)
}
if (anyDuplicated(raw_id) != 0L) {
stop(
"x$data$pu_data_raw$id contains duplicated planning unit ids.",
call. = FALSE
)
}
m <- match(pu_id, raw_id)
if (anyNA(m)) {
stop(
"Could not match all x$data$pu$id values to x$data$pu_data_raw$id ",
"while retrieving planning unit areas.",
call. = FALSE
)
}
as.numeric(raw[[col]][m])
}
# ---------------------------------------------------------
# 1) explicit area_col
# ---------------------------------------------------------
if (!is.null(area_col)) {
area_col <- as.character(area_col)[1]
if (is.na(area_col) || !nzchar(area_col)) {
stop(
"area_col must be a non-empty string or NULL.",
call. = FALSE
)
}
# 1a) from x$data$pu
if (area_col %in% names(pu)) {
area <- as.numeric(pu[[area_col]])
area_source <- "pu"
area_col_used <- area_col
# 1b) from x$data$pu_sf
} else if (
!is.null(x$data$pu_sf) &&
inherits(x$data$pu_sf, "sf") &&
area_col %in% names(x$data$pu_sf)
) {
area <- as.numeric(x$data$pu_sf[[area_col]])
area_source <- "pu_sf"
area_col_used <- area_col
# 1c) from x$data$pu_data_raw
} else if (
!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame") &&
area_col %in% names(x$data$pu_data_raw)
) {
area <- get_raw_area(area_col)
area_source <- "pu_data_raw"
area_col_used <- area_col
} else {
stop(
"area_col '", area_col, "' was not found in x$data$pu",
if (!is.null(x$data$pu_sf) && inherits(x$data$pu_sf, "sf")) {
", x$data$pu_sf"
} else {
""
},
if (!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame")) {
", or x$data$pu_data_raw."
} else {
"."
},
" Provide a valid area column or spatial information.",
call. = FALSE
)
}
}
# ---------------------------------------------------------
# 2) automatic lookup if area_col is NULL
# ---------------------------------------------------------
cand <- c(
"area",
"Area",
"AREA",
"surf",
"surface",
"area_m2",
"area_ha",
"area_km2"
)
# 2a) automatic lookup in x$data$pu
if (is.null(area)) {
hit_pu <- cand[cand %in% names(pu)][1]
if (!is.na(hit_pu) && length(hit_pu) == 1L) {
area <- as.numeric(pu[[hit_pu]])
area_source <- "pu"
area_col_used <- hit_pu
}
}
# 2b) automatic lookup in x$data$pu_sf
if (
is.null(area) &&
!is.null(x$data$pu_sf) &&
inherits(x$data$pu_sf, "sf")
) {
hit_sf <- cand[cand %in% names(x$data$pu_sf)][1]
if (!is.na(hit_sf) && length(hit_sf) == 1L) {
area <- as.numeric(x$data$pu_sf[[hit_sf]])
area_source <- "pu_sf"
area_col_used <- hit_sf
}
}
# 2c) automatic lookup in x$data$pu_data_raw
if (
is.null(area) &&
!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame")
) {
hit_raw <- cand[cand %in% names(x$data$pu_data_raw)][1]
if (!is.na(hit_raw) && length(hit_raw) == 1L) {
area <- get_raw_area(hit_raw)
area_source <- "pu_data_raw"
area_col_used <- hit_raw
}
}
# ---------------------------------------------------------
# 3) derive from geometry if possible
# ---------------------------------------------------------
if (is.null(area)) {
if (!is.null(x$data$pu_sf) && inherits(x$data$pu_sf, "sf")) {
area <- as.numeric(sf::st_area(x$data$pu_sf))
area_source <- "geometry_sf"
area_col_used <- NA_character_
# future raster branch could go here
# else if (...) {
# area <- ...
# area_source <- "geometry_raster"
# }
} else {
stop(
"Could not retrieve planning unit area.\n",
"No usable area column was found in x$data$pu",
if (!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame")) {
" or x$data$pu_data_raw"
} else {
""
},
", and no spatial geometry is available to derive area internally.\n",
"Provide `area_col` explicitly or build the Problem object with spatial information.",
call. = FALSE
)
}
}
# ---------------------------------------------------------
# 4) validate length and values
# ---------------------------------------------------------
if (length(area) != n_pu) {
stop(
"Area vector length (", length(area), ") != n_pu (", n_pu, "). ",
"Area source: ", area_source,
if (!is.null(area_col_used) && !is.na(area_col_used)) {
paste0(" [column='", area_col_used, "']")
} else {
""
},
".",
call. = FALSE
)
}
if (anyNA(area) || any(!is.finite(area))) {
stop(
"Area vector contains NA or non-finite values.",
call. = FALSE
)
}
if (any(area < 0)) {
stop(
"Area vector contains negative values.",
call. = FALSE
)
}
# ---------------------------------------------------------
# 5) convert to requested output units
# assume raw geometry/st_area is m2
# if column name suggests ha/km2, convert accordingly
# ---------------------------------------------------------
area_m2 <- area
if (!is.null(area_col_used) && !is.na(area_col_used)) {
nm <- tolower(area_col_used)
if (grepl("km2", nm, fixed = TRUE)) {
area_m2 <- area * 1e6
} else if (grepl("ha", nm, fixed = TRUE)) {
area_m2 <- area * 1e4
} else {
# assume already in m2 for generic names like area/surf/surface
area_m2 <- area
}
}
out <- switch(
area_unit,
m2 = area_m2,
ha = area_m2 / 1e4,
km2 = area_m2 / 1e6
)
names(out) <- as.character(pu$id)
out
}
# helper: ensure model built and model_list snapshot available
.pa_ensure_model_snapshot <- function(x) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_ptr)) {
x <- .pa_build_model(x)
}
if (is.null(x$data$model_list) || isTRUE(x$data$meta$model_dirty)) {
x <- .pa_refresh_model_snapshot(x)
x$data$meta$model_dirty <- FALSE
}
x
}
# helper: add 1 linear constraint sum(coeff_j * x_j) (sense) rhs
# NOTE: replace this with YOUR real C++ bridge that appends rows/triplets/rhs/sense.
.pa_add_linear_constraint <- function(
x,
var_index_0based,
coeff,
sense = c(">=", "<=", "=="),
rhs,
name = NULL,
block_name = "linear_constraint",
tag = "",
drop_zeros = TRUE,
merge_duplicates = TRUE,
refresh_snapshot = FALSE
) {
sense <- match.arg(sense)
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_ptr)) {
stop("Model pointer missing. Build model first.", call. = FALSE)
}
# ---- validate inputs
if (!is.numeric(var_index_0based) || !is.numeric(coeff)) {
stop("var_index_0based and coeff must be numeric.", call. = FALSE)
}
if (length(var_index_0based) != length(coeff)) {
stop("Length mismatch: var_index_0based and coeff must have the same length.", call. = FALSE)
}
if (!is.numeric(rhs) || length(rhs) != 1L || !is.finite(rhs)) {
stop("rhs must be a single finite numeric value.", call. = FALSE)
}
j0 <- as.integer(var_index_0based)
a <- as.numeric(coeff)
# ---- drop NA / non-finite / zero
keep <- !(is.na(j0) | is.na(a) | !is.finite(a))
if (isTRUE(drop_zeros)) keep <- keep & (a != 0)
j0 <- j0[keep]
a <- a[keep]
if (length(j0) == 0L) {
stop("Linear constraint has no non-zero coefficients after filtering.", call. = FALSE)
}
# ---- optionally merge duplicates (important if you build vectors by rbind/cbind)
if (isTRUE(merge_duplicates) && length(j0) > 1L) {
o <- order(j0)
j0 <- j0[o]; a <- a[o]
# aggregate by j0
u <- unique(j0)
a2 <- numeric(length(u))
idx <- match(j0, u)
for (k in seq_along(a)) a2[idx[k]] <- a2[idx[k]] + a[k]
j0 <- u
a <- a2
if (isTRUE(drop_zeros)) {
keep2 <- a != 0
j0 <- j0[keep2]
a <- a[keep2]
}
if (length(j0) == 0L) {
stop("Linear constraint became empty after merging duplicates.", call. = FALSE)
}
}
name <- as.character(name %||% "")[1]
block_name <- as.character(block_name %||% "linear_constraint")[1]
tag <- as.character(tag %||% "")[1]
# ---- call C++
out <- rcpp_add_linear_constraint(
model_ptr = x$data$model_ptr,
j0 = j0,
x = a,
sense = sense,
rhs = as.numeric(rhs),
name = name,
block_name = block_name,
tag = tag
)
if (isTRUE(refresh_snapshot)) {
x <- .pa_refresh_model_snapshot(x)
}
# store last-added info (optional, but handy for debugging)
x$data$model_registry <- x$data$model_registry %||% list()
x$data$model_registry$last_linear_constraint <- out
x
}
# -------------------------------------------------------------------------
# Internal helpers spatial relations
# -------------------------------------------------------------------------
.pa_validate_relation <- function(rel, n_pu, allow_self = FALSE,
dup_agg = c("sum", "max", "min", "mean")) {
stopifnot(is.data.frame(rel))
dup_agg <- match.arg(dup_agg)
req <- c("internal_pu1", "internal_pu2", "weight")
miss <- setdiff(req, names(rel))
if (length(miss) > 0) stop("Relation is missing columns: ", paste(miss, collapse = ", "), call. = FALSE)
rel$internal_pu1 <- as.integer(rel$internal_pu1)
rel$internal_pu2 <- as.integer(rel$internal_pu2)
rel$weight <- as.numeric(rel$weight)
if (anyNA(rel$internal_pu1) || anyNA(rel$internal_pu2) || anyNA(rel$weight)) {
stop("Relation has NA in internal_pu1/internal_pu2/weight.", call. = FALSE)
}
if (any(rel$internal_pu1 < 1L | rel$internal_pu1 > n_pu)) stop("internal_pu1 out of range.", call. = FALSE)
if (any(rel$internal_pu2 < 1L | rel$internal_pu2 > n_pu)) stop("internal_pu2 out of range.", call. = FALSE)
if (!allow_self && any(rel$internal_pu1 == rel$internal_pu2)) stop("Self-edges are not allowed.", call. = FALSE)
if (any(!is.finite(rel$weight)) || any(rel$weight < 0)) stop("weight must be finite and >= 0.", call. = FALSE)
# undirected canonical ordering
a <- pmin(rel$internal_pu1, rel$internal_pu2)
b <- pmax(rel$internal_pu1, rel$internal_pu2)
rel$internal_pu1 <- a
rel$internal_pu2 <- b
# columns to keep
core <- c("internal_pu1", "internal_pu2", "weight")
extra_cols <- intersect(names(rel), c("pu1","pu2","distance","source"))
keep <- c(core, extra_cols)
# aggregate duplicates
key <- paste(rel$internal_pu1, rel$internal_pu2)
if (anyDuplicated(key) != 0) {
FUN <- switch(
dup_agg,
sum = sum,
max = max,
min = min,
mean = mean
)
# aggregate ONLY weight (core), then optionally restore extras deterministically
agg <- stats::aggregate(
weight ~ internal_pu1 + internal_pu2,
data = rel[, core, drop = FALSE],
FUN = FUN
)
# if extras exist, attach a deterministic representative per edge (first row)
if (length(extra_cols) > 0) {
# representative rows: first occurrence per key
rep_idx <- match(paste(agg$internal_pu1, agg$internal_pu2),
paste(rel$internal_pu1, rel$internal_pu2))
extras <- rel[rep_idx, extra_cols, drop = FALSE]
agg <- cbind(agg, extras)
}
rel <- agg
} else {
rel <- rel[, keep, drop = FALSE]
}
rel
}
.pa_action_weights_vector <- function(actions_df,
action_weights = NULL,
subset_actions = NULL,
default_weight = 1) {
stopifnot(is.data.frame(actions_df), nrow(actions_df) > 0)
n_actions <- nrow(actions_df)
w <- rep(as.numeric(default_weight)[1], n_actions)
if (!is.null(subset_actions)) {
subset_actions <- as.integer(subset_actions)
if (anyNA(subset_actions)) stop("subset_actions contains NA.", call. = FALSE)
if (any(subset_actions < 1L | subset_actions > n_actions)) {
stop("subset_actions out of range (1..n_actions).", call. = FALSE)
}
# si se especifica subset y NO se da vector completo, el default para acciones fuera del subset suele ser 0
w[-subset_actions] <- 0
}
if (!is.null(action_weights)) {
action_weights <- as.numeric(action_weights)
if (any(!is.finite(action_weights)) || any(action_weights < 0)) {
stop("action_weights must be finite and >= 0.", call. = FALSE)
}
if (length(action_weights) == n_actions) {
w <- action_weights
} else if (!is.null(subset_actions) && length(action_weights) == length(subset_actions)) {
w[subset_actions] <- action_weights
} else {
stop(
"action_weights must have length n_actions (= ", n_actions, ") ",
"or length(subset_actions) (= ", length(subset_actions) %||% 0, ").",
call. = FALSE
)
}
}
w
}
.pa_model_frag_vars_summary <- function(x) {
if (!inherits(x, "Problem")) return(NULL)
ml <- x$data$model_list
if (is.null(ml) || !is.list(ml)) return(NULL)
# defensivo: algunos campos pueden no existir
get_int0 <- function(nm) {
v <- ml[[nm]]
if (is.null(v)) return(0L)
as.integer(v)[1]
}
out <- list(
n_y_pu = get_int0("n_y_pu"),
n_y_actions = get_int0("n_y_actions"),
n_y_interventions = get_int0("n_y_interventions"),
y_pu_offset = get_int0("y_pu_offset"),
y_actions_offset = get_int0("y_actions_offset"),
y_interventions_offset = get_int0("y_interventions_offset")
)
# si no hay ninguna y*, devuelve NULL para no ensuciar print
if ((out$n_y_pu + out$n_y_actions + out$n_y_interventions) == 0L) return(NULL)
out
}
# -------------------------------------------------------------------------
# Internal helpers multi objectives
# -------------------------------------------------------------------------
.pa_abort <- function(...) stop(paste0(...), call. = FALSE)
.pa_apply_runtime_updates_to_model <- function(model, x) {
upd <- x$data$runtime_updates %||% list()
reg <- x$data$model_registry %||% list()
# nada que hacer
if (length(upd) == 0) return(model)
bigM <- as.numeric(upd$bigM %||% 1e15)[1]
# Helper: relajar una fila para que sea redundante
relax_row <- function(i) {
s <- model$sense[i]
if (identical(s, ">=")) {
model$rhs[i] <<- -bigM
} else if (identical(s, "<=")) {
model$rhs[i] <<- bigM
} else if (identical(s, "==") || identical(s, "=")) {
model$sense[i] <<- "<="
model$rhs[i] <<- bigM
} else {
# por seguridad: si aparece algo raro, lo relajo como <= bigM
model$sense[i] <<- "<="
model$rhs[i] <<- bigM
}
invisible(NULL)
}
# 1) activar/desactivar constraints por grupos (si el registry lo soporta)
# upd$deactivate_constraints puede ser vector de ids lógicos (por nombre) o filas directas
if (!is.null(upd$deactivate_rows)) {
rows <- as.integer(upd$deactivate_rows)
rows <- rows[rows >= 1L & rows <= length(model$rhs)]
for (i in rows) relax_row(i)
}
if (!is.null(upd$deactivate_groups) && !is.null(reg$cons)) {
gs <- as.character(upd$deactivate_groups)
for (g in gs) {
rows <- reg$cons[[g]] %||% integer(0)
rows <- as.integer(rows)
rows <- rows[rows >= 1L & rows <= length(model$rhs)]
for (i in rows) relax_row(i)
}
}
# 2) epsilons: update RHS de constraints epsilon (sin cambiar estructura)
# ejemplo: upd$epsilon <- list(f2 = 0.25, f3 = 10)
if (!is.null(upd$epsilon) && !is.null(reg$cons$epsilon)) {
eps_list <- upd$epsilon
for (nm in names(eps_list)) {
rows <- reg$cons$epsilon[[nm]] %||% integer(0)
rows <- as.integer(rows)
if (length(rows) == 0) next
rhs <- as.numeric(eps_list[[nm]])[1]
# aquí asumes que la fila es del tipo f(x) >= epsilon
model$rhs[rows] <- rhs
}
}
# 3A) objetivo: override directo (vector obj completo)
# Esto es lo que necesita multiscape (weighted, etc.)
if (!is.null(upd$obj)) {
obj_new <- as.numeric(upd$obj)
if (length(obj_new) != length(model$obj)) {
stop(
"runtime_updates$obj length mismatch: ",
length(obj_new), " != ", length(model$obj),
call. = FALSE
)
}
model$obj <- obj_new
if (!is.null(upd$modelsense)) {
ms <- as.character(upd$modelsense)[1]
if (!ms %in% c("min", "max")) stop("runtime_updates$modelsense must be 'min' or 'max'.", call. = FALSE)
model$modelsense <- ms
}
}
else if (!is.null(upd$objective_template) && !is.null(reg$obj_templates)) {
tpl <- reg$obj_templates[[upd$objective_template]]
if (!is.null(tpl)) {
if (length(tpl$obj) != length(model$obj)) {
stop("Objective template length mismatch.", call. = FALSE)
}
model$obj <- tpl$obj
if (!is.null(tpl$modelsense)) model$modelsense <- tpl$modelsense
}
}
# 4) pesos AUGMECON: por ejemplo coef de slacks en obj (sin reconstruir)
if (!is.null(upd$slack_weight) && !is.null(reg$vars$slack)) {
w <- as.numeric(upd$slack_weight)[1]
slack_ids <- as.integer(reg$vars$slack)
slack_ids <- slack_ids[slack_ids >= 1L & slack_ids <= length(model$obj)]
model$obj[slack_ids] <- w
}
model
}
# -------------------------------------------------------------------------
# Internal helpers spatial relations
# -------------------------------------------------------------------------
.pa_create_problem_tabular_impl <- function(pu, features, dist_features, boundary = NULL, ...) {
dots <- list(...)
`%||%` <- function(a, b) if (!is.null(a)) a else b
pu_coords <- NULL
# helper: coerce ids to integer safely
.as_int_id <- function(x, what) {
.pa_as_int_id(x, what)
}
# keep raw PU table for downstream helpers such as add_locked_pu()
pu_raw <- pu
# =========================
# PU: validate + normalize
# =========================
assertthat::assert_that(
inherits(pu, "data.frame"),
assertthat::has_name(pu, "id"),
nrow(pu) > 0,
assertthat::noNA(pu$id)
)
pu$id <- .as_int_id(pu$id, "pu$id")
if (anyDuplicated(pu$id) != 0) stop("pu$id must be unique.", call. = FALSE)
# accept cost or monitoring_cost -> normalize to cost
if ("cost" %in% names(pu)) {
assertthat::assert_that(is.numeric(pu$cost), assertthat::noNA(pu$cost))
} else if ("monitoring_cost" %in% names(pu)) {
assertthat::assert_that(is.numeric(pu$monitoring_cost), assertthat::noNA(pu$monitoring_cost))
pu$cost <- pu$monitoring_cost
} else {
stop("pu must contain either a 'cost' column or a 'monitoring_cost' column.", call. = FALSE)
}
# IMPORTANT:
# internal contract: pu always carries locked_in / locked_out,
# defaulting to FALSE when they are not provided.
if (!("locked_in" %in% names(pu))) pu$locked_in <- FALSE
if (!("locked_out" %in% names(pu))) pu$locked_out <- FALSE
pu$locked_in <- as.logical(pu$locked_in)
pu$locked_out <- as.logical(pu$locked_out)
pu$locked_in[is.na(pu$locked_in)] <- FALSE
pu$locked_out[is.na(pu$locked_out)] <- FALSE
if (any(pu$locked_in & pu$locked_out, na.rm = TRUE)) {
stop("Some planning units are both locked_in and locked_out. Please fix pu input.", call. = FALSE)
}
# optional: store coordinates if present (tabular users)
if (all(c("x", "y") %in% names(pu))) {
pu_coords <- data.frame(
id = pu$id,
x = as.numeric(pu$x),
y = as.numeric(pu$y),
stringsAsFactors = FALSE
)
if (any(!is.finite(pu_coords$x) | !is.finite(pu_coords$y))) {
stop("pu$x/pu$y contain non-finite values.", call. = FALSE)
}
}
# internal PU table keeps the core fields needed by the model
pu <- pu[, c("id", "cost", "locked_in", "locked_out"), drop = FALSE]
pu <- pu[order(pu$id), , drop = FALSE]
# raw PU table aligned to normalized id order
pu_raw$id <- .as_int_id(pu_raw$id, "pu_raw$id")
pu_raw <- pu_raw[match(pu$id, pu_raw$id), , drop = FALSE]
# internal ids + lookup
pu$internal_id <- seq_len(nrow(pu))
pu_index <- stats::setNames(pu$internal_id, as.character(pu$id))
# =========================
# FEATURES: validate + normalize
# =========================
assertthat::assert_that(
inherits(features, "data.frame"),
assertthat::has_name(features, "id"),
nrow(features) > 0,
assertthat::noNA(features$id)
)
features$id <- .as_int_id(features$id, "features$id")
if (anyDuplicated(features$id) != 0) stop("features$id must be unique.", call. = FALSE)
if (!("name" %in% names(features))) {
features$name <- paste0("feature.", seq_len(nrow(features)))
} else {
features$name <- as.character(features$name)
assertthat::assert_that(assertthat::noNA(features$name))
if (anyDuplicated(features$name) != 0) stop("features$name must be unique.", call. = FALSE)
}
features <- features[, c("id", "name", setdiff(names(features), c("id", "name"))), drop = FALSE]
features <- features[order(features$id), , drop = FALSE]
features$internal_id <- seq_len(nrow(features))
feature_index <- stats::setNames(features$internal_id, as.character(features$id))
# =========================
# DIST_FEATURES: validate + normalize
# =========================
assertthat::assert_that(
inherits(dist_features, "data.frame"),
assertthat::has_name(dist_features, "pu"),
assertthat::has_name(dist_features, "feature"),
assertthat::has_name(dist_features, "amount"),
nrow(dist_features) > 0,
assertthat::noNA(dist_features$pu),
assertthat::noNA(dist_features$feature),
assertthat::noNA(dist_features$amount),
is.numeric(dist_features$amount),
all(is.finite(dist_features$amount)),
all(dist_features$amount >= 0)
)
dist_features$pu <- .as_int_id(dist_features$pu, "dist_features$pu")
dist_features$feature <- .as_int_id(dist_features$feature, "dist_features$feature")
if (!all(dist_features$pu %in% pu$id)) {
bad <- unique(dist_features$pu[!dist_features$pu %in% pu$id])
stop("dist_features contains unknown PU ids: ", paste(bad, collapse = ", "), call. = FALSE)
}
if (!all(dist_features$feature %in% features$id)) {
bad <- unique(dist_features$feature[!dist_features$feature %in% features$id])
stop("dist_features contains unknown feature ids: ", paste(bad, collapse = ", "), call. = FALSE)
}
dist_features <- dist_features[dist_features$amount != 0, , drop = FALSE]
key <- paste(dist_features$pu, dist_features$feature, sep = "||")
if (anyDuplicated(key) != 0) stop("There are duplicate (pu, feature) pairs in dist_features.", call. = FALSE)
dist_features$internal_pu <- unname(pu_index[as.character(dist_features$pu)])
dist_features$internal_feature <- unname(feature_index[as.character(dist_features$feature)])
dist_features <- dist_features[order(dist_features$internal_pu, dist_features$internal_feature), , drop = FALSE]
dist_features$internal_row <- seq_len(nrow(dist_features))
# =========================
# BOUNDARY: validate + normalize
# =========================
assertthat::assert_that(is.null(boundary) || inherits(boundary, "data.frame"))
if (inherits(boundary, "data.frame")) {
assertthat::assert_that(
assertthat::has_name(boundary, "id1"),
assertthat::has_name(boundary, "id2"),
assertthat::has_name(boundary, "boundary"),
assertthat::noNA(boundary$id1),
assertthat::noNA(boundary$id2),
assertthat::noNA(boundary$boundary),
is.numeric(boundary$boundary)
)
boundary$id1 <- .as_int_id(boundary$id1, "boundary$id1")
boundary$id2 <- .as_int_id(boundary$id2, "boundary$id2")
if (!all(boundary$id1 %in% pu$id) || !all(boundary$id2 %in% pu$id)) {
warning("boundary contains PU ids not present in pu; they will be removed.", call. = FALSE, immediate. = TRUE)
keep <- boundary$id1 %in% pu$id & boundary$id2 %in% pu$id
boundary <- boundary[keep, , drop = FALSE]
}
if (nrow(boundary) == 0) boundary <- NULL
}
# =========================
# useful warnings
# =========================
dif_pu <- setdiff(unique(pu$id), unique(dist_features$pu))
if (length(dif_pu) != 0L) {
warning(
paste0("The following pu's do not contain features: ", paste(dif_pu, collapse = " ")),
call. = FALSE, immediate. = TRUE
)
}
dif_features <- setdiff(unique(features$id), unique(dist_features$feature))
if (length(dif_features) != 0L) {
warning(
paste0("The following features are not represented in dist_features: ", paste(dif_features, collapse = " ")),
call. = FALSE, immediate. = TRUE
)
}
# =========================
# build Problem object
# =========================
x <- pproto(
NULL, Problem,
data = list(
pu = pu,
pu_data_raw = pu_raw,
features = features,
dist_features = dist_features,
# ---- spatial / auxiliary storage
pu_coords = pu_coords,
spatial_relations = list(),
index = list(
pu = pu_index,
feature = feature_index,
feature_name_to_id = stats::setNames(features$id, features$name)
),
meta = list(
dist_features_meaning = "baseline_amount",
dist_benefit_meaning = "delta_by_default"
),
# workflow placeholders
actions = NULL,
dist_actions = NULL,
dist_benefit = NULL,
locked_actions = NULL,
targets = NULL,
objective = NULL,
decisions = NULL,
solver = NULL
)
)
# =========================
# boundary -> spatial relation ("boundary")
# =========================
if (!is.null(boundary) && inherits(boundary, "data.frame") && nrow(boundary) > 0) {
rel <- data.frame(
internal_pu1 = unname(pu_index[as.character(boundary$id1)]),
internal_pu2 = unname(pu_index[as.character(boundary$id2)]),
weight = as.numeric(boundary$boundary),
source = "boundary_table",
stringsAsFactors = FALSE
)
if (anyNA(rel$internal_pu1) || anyNA(rel$internal_pu2)) {
stop("boundary contains PU ids not present in pu (after filtering).", call. = FALSE)
}
rel <- .pa_validate_relation(rel, n_pu = nrow(pu), allow_self = FALSE, dup_agg = "sum")
rel$relation_name <- "boundary"
if (is.null(x$data$spatial_relations) || !is.list(x$data$spatial_relations)) {
x$data$spatial_relations <- list()
}
x$data$spatial_relations[["boundary"]] <- rel
}
x
}
# -------------------------------------------------------------------------
# Internal helpers objective relations
# -------------------------------------------------------------------------
.pa_register_objective <- function(
x,
alias,
objective_id,
model_type,
objective_args = list(),
sense = c("min", "max")
) {
stopifnot(inherits(x, "Problem"))
if (is.null(alias)) return(x)
alias <- as.character(alias)[1]
if (is.na(alias) || !nzchar(alias)) {
stop("alias must be a non-empty string.", call. = FALSE)
}
objective_id <- as.character(objective_id)[1]
if (is.na(objective_id) || !nzchar(objective_id)) {
stop("objective_id must be a non-empty string.", call. = FALSE)
}
model_type <- as.character(model_type)[1]
if (is.na(model_type) || !nzchar(model_type)) {
stop("model_type must be a non-empty string.", call. = FALSE)
}
sense <- match.arg(sense)
if (is.null(objective_args)) {
objective_args <- list()
}
if (!is.list(objective_args)) {
stop("objective_args must be a list.", call. = FALSE)
}
if (is.null(x$data$objectives) || !is.list(x$data$objectives)) {
x$data$objectives <- list()
}
# prevent duplicated aliases
if (!is.null(x$data$objectives[[alias]])) {
stop(
"Objective alias '", alias, "' already exists. ",
"Use a different alias.",
call. = FALSE
)
}
x$data$objectives[[alias]] <- list(
alias = alias,
objective_id = objective_id,
model_type = model_type,
objective_args = objective_args,
sense = sense,
created_at = as.character(Sys.time())
)
# keep deterministic ordering by alias
x$data$objectives <- x$data$objectives[sort(names(x$data$objectives))]
# if a model already exists, mark dirty
if (!is.null(x$data$model_ptr)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$model_dirty <- TRUE
}
x
}
# internal registry for MO objectives inside Problem
# .pa_init_objectives <- function(x) {
# if (is.null(x$data$objectives) || !is.list(x$data$objectives)) {
# x$data$objectives <- list()
# }
# x
# }
# .pa_get_objective_specs <- function(x) {
# if (is.null(x$data$objectives)) return(list())
# x$data$objectives
# }
# .pa_set_objective_linear <- function(x, obj, modelsense = c("min", "max")) {
# stopifnot(inherits(x, "Problem"))
# modelsense <- match.arg(modelsense)
#
# # guarda runtime update para que .pa_apply_runtime_updates_to_model() lo aplique
# x$data$runtime_updates <- x$data$runtime_updates %||% list()
# x$data$runtime_updates$obj <- as.numeric(obj)
# x$data$runtime_updates$modelsense <- modelsense
#
# # marca "dirty" para que se regenere model_list desde ptr si aplica (o solo runtime update)
# x$data$meta$model_dirty <- TRUE
# x
# }
# .pa_mark_mo_needs <- function(x, needs) {
# stopifnot(inherits(x, "Problem"))
# x$data$mo <- x$data$mo %||% list()
# x$data$mo$needs <- utils::modifyList(x$data$mo$needs %||% list(), needs)
# x$data$meta$model_dirty <- TRUE
# x
# }
.pa_fast_extract <- function(x, y, fun = c("sum", "mean", "max")) {
fun <- match.arg(fun)
stopifnot(inherits(x, "terra::SpatRaster") || inherits(x, "SpatRaster"))
stopifnot(inherits(y, "terra::SpatVector") || inherits(y, "SpatVector") || inherits(y, "sf"))
if (inherits(y, "SpatVector")) {
if (!requireNamespace("sf", quietly = TRUE)) stop("Need 'sf' to convert SpatVector -> sf.", call. = FALSE)
y <- sf::st_as_sf(y)
}
out <- matrix(NA_real_, nrow = nrow(y), ncol = terra::nlyr(x))
colnames(out) <- make.unique(names(x))
geomc <- as.character(sf::st_geometry_type(y, by_geometry = TRUE))
# points
point_idx <- grepl("POINT", geomc, fixed = TRUE)
if (any(point_idx)) {
ex <- terra::extract(x = x, y = sf::st_coordinates(y[point_idx, , drop = FALSE]))
out[point_idx, ] <- as.matrix(ex[, -1, drop = FALSE]) # drop ID column
}
# lines
line_idx <- grepl("LINE", geomc, fixed = TRUE)
if (any(line_idx)) {
fun2 <- switch(fun, mean = mean, sum = sum, max = max)
out[line_idx, ] <- as.matrix(
terra::extract(
x = x,
y = terra::vect(y[line_idx, , drop = FALSE]),
ID = FALSE,
touches = TRUE,
fun = fun2,
na.rm = TRUE
)
)
}
# polygons (prioritizr-like)
poly_idx <- grepl("POLYGON", geomc, fixed = TRUE)
if (any(poly_idx)) {
if (!requireNamespace("exactextractr", quietly = TRUE)) {
stop("Polygon feature extraction requires 'exactextractr'.", call. = FALSE)
}
# IMPORTANT: avoid mutating user's objects
y2 <- y[poly_idx, , drop = FALSE]
x2 <- x
# (this is just to silence CRS/proj warnings like prioritizr; extraction uses coordinates)
sf::st_crs(y2) <- sf::st_crs(NA_character_)
terra::crs(x2) <- NA_character_
out[poly_idx, ] <- as.matrix(
exactextractr::exact_extract(
x2,
y2,
fun = fun,
max_cells_in_memory = 1e6,
progress = FALSE
)
)
}
out[!is.finite(out)] <- 0
out[abs(out) < 1e-10] <- 0
out
}
# -------------------------------------------------------------------------
# Internal helpers SPATIAL relations
# -------------------------------------------------------------------------
.pa_has_sf <- function() requireNamespace("sf", quietly = TRUE)
.pa_ensure_pu_index <- function(x) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$pu) || !inherits(x$data$pu, "data.frame")) {
stop("x$data$pu is missing. Create the problem with create_problem().", call. = FALSE)
}
if (is.null(x$data$pu$internal_id)) x$data$pu$internal_id <- seq_len(nrow(x$data$pu))
if (is.null(x$data$pu$id)) {
stop("x$data$pu must contain column 'id' (planning unit id).", call. = FALSE)
}
x$data$pu$id <- as.integer(x$data$pu$id)
x$data$pu$internal_id <- as.integer(x$data$pu$internal_id)
if (anyNA(x$data$pu$id) || anyNA(x$data$pu$internal_id)) {
stop("x$data$pu$id/internal_id contain NA after coercion.", call. = FALSE)
}
if (anyDuplicated(x$data$pu$internal_id) != 0) stop("x$data$pu$internal_id must be unique.", call. = FALSE)
if (anyDuplicated(x$data$pu$id) != 0) stop("x$data$pu$id must be unique.", call. = FALSE)
if (is.null(x$data$index) || !is.list(x$data$index)) x$data$index <- list()
x$data$index$pu <- stats::setNames(x$data$pu$internal_id, as.character(x$data$pu$id))
x
}
.pa_store_relation <- function(x, rel, name) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$spatial_relations) || !is.list(x$data$spatial_relations)) {
x$data$spatial_relations <- list()
}
if (name %in% names(x$data$spatial_relations)) {
stop("Spatial relation '", name, "' already exists. Use a new name or rebuild ",
"from the problem before this relation to change it.", call. = FALSE)
}
x$data$spatial_relations[[name]] <- rel
x
}
.pa_coords_from_input <- function(x, coords = NULL) {
stopifnot(inherits(x, "Problem"))
if (!is.null(coords)) {
if (inherits(coords, "data.frame")) {
if (!all(c("id", "x", "y") %in% names(coords))) {
stop("coords data.frame must contain columns id, x, y.", call. = FALSE)
}
out <- coords[, c("id", "x", "y")]
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
if (is.matrix(coords)) {
if (ncol(coords) < 2) stop("coords matrix must have at least 2 columns (x,y).", call. = FALSE)
out <- data.frame(id = x$data$pu$id, x = coords[, 1], y = coords[, 2])
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
stop("Unsupported coords type. Use data.frame(id,x,y) or a matrix with 2 columns.", call. = FALSE)
}
# NEW fallback: x$data$pu_coords
if (!is.null(x$data$pu_coords) && inherits(x$data$pu_coords, "data.frame")) {
pc <- x$data$pu_coords
if (all(c("id", "x", "y") %in% names(pc))) {
out <- pc[, c("id", "x", "y")]
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
}
# fallback: try x$data$pu columns
if (all(c("x", "y") %in% names(x$data$pu))) {
out <- data.frame(id = x$data$pu$id, x = x$data$pu$x, y = x$data$pu$y)
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
stop(
"No coordinates available. Provide coords=data.frame(id,x,y) or store x$data$pu_coords (id,x,y), or add x$data$pu$x/y.",
call. = FALSE
)
}
.pa_get_pu_sf_aligned <- function(x, pu_sf = NULL, arg_name = "pu_sf") {
stopifnot(inherits(x, "Problem"))
x <- .pa_ensure_pu_index(x)
if (is.null(pu_sf)) pu_sf <- x$data$pu_sf
if (is.null(pu_sf)) {
stop(
arg_name, " is NULL and x$data$pu_sf is missing.\n",
"Provide ", arg_name, " (sf polygons with an 'id' column) or make sure create_problem() stored x$data$pu_sf.",
call. = FALSE
)
}
if (!requireNamespace("sf", quietly = TRUE)) {
stop("This function requires the 'sf' package.", call. = FALSE)
}
if (!inherits(pu_sf, "sf")) stop(arg_name, " must be an sf object.", call. = FALSE)
if (!("id" %in% names(pu_sf))) stop(arg_name, " must contain an 'id' column.", call. = FALSE)
pu_sf$id <- as.integer(pu_sf$id)
# align to x$data$pu$id (critical)
ord <- match(x$data$pu$id, pu_sf$id)
if (anyNA(ord)) {
missing_ids <- x$data$pu$id[is.na(ord)]
stop(
arg_name, "$id does not match x$data$pu$id (some ids missing). Missing: ",
paste(utils::head(missing_ids, 20), collapse = ", "),
if (length(missing_ids) > 20) " ..." else "",
call. = FALSE
)
}
pu_sf[ord, , drop = FALSE]
}
.pa_rbind_fill <- function(a, b) {
stopifnot(inherits(a, "data.frame"), inherits(b, "data.frame"))
cols <- union(names(a), names(b))
for (cc in setdiff(cols, names(a))) a[[cc]] <- NA
for (cc in setdiff(cols, names(b))) b[[cc]] <- NA
a <- a[, cols, drop = FALSE]
b <- b[, cols, drop = FALSE]
rbind(a, b)
}
.pa_swap_edges <- function(rel) {
out <- rel
out$internal_pu1 <- rel$internal_pu2
out$internal_pu2 <- rel$internal_pu1
if ("pu1" %in% names(rel) && "pu2" %in% names(rel)) {
out$pu1 <- rel$pu2
out$pu2 <- rel$pu1
}
out
}
# -------------------------------------------------------------------------
# Needs flags (feature requirements) for build
# -------------------------------------------------------------------------
.pa_needs_default <- function() {
list(
z = FALSE, # z vars (representation)
y_pu = FALSE, # PU fragmentation auxiliaries
y_action = FALSE, # action fragmentation auxiliaries
y_intervention = FALSE, # intervention fragmentation auxiliaries
u_intervention = FALSE # intervention extra vars (if applicable)
)
}
.pa_build_model_init_needs <- function(x) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_args) || !is.list(x$data$model_args)) x$data$model_args <- list()
needs <- x$data$model_args$needs
if (is.null(needs) || !is.list(needs)) needs <- list()
# merge defaults without overwriting existing values
def <- .pa_needs_default()
for (nm in names(def)) {
if (is.null(needs[[nm]])) needs[[nm]] <- def[[nm]]
}
x$data$model_args$needs <- needs
x
}
.pa_build_model_set_needs_from_objective <- function(x) {
stopifnot(inherits(x, "Problem"))
args <- x$data$model_args %||% list()
mtype <- args$model_type %||% "minimizeCosts"
oargs <- args$objective_args %||% list()
raw_needs <- args$needs %||% list()
needs <- .pa_needs_default()
# decisión de diseño actual: z siempre disponible
needs$z <- TRUE
# primero respetamos overrides explícitos si vienen dados
if (!is.null(raw_needs$z)) needs$z <- isTRUE(raw_needs$z)
if (!is.null(raw_needs$y_pu)) needs$y_pu <- isTRUE(raw_needs$y_pu)
if (!is.null(raw_needs$y_action)) needs$y_action <- isTRUE(raw_needs$y_action)
if (!is.null(raw_needs$y_intervention)) needs$y_intervention <- isTRUE(raw_needs$y_intervention)
if (!is.null(raw_needs$u_intervention)) needs$u_intervention <- isTRUE(raw_needs$u_intervention)
# luego inferimos solo lo que no vino explícito
if (is.null(raw_needs$y_pu)) {
needs$y_pu <- identical(mtype, "minimizeFragmentation")
}
if (is.null(raw_needs$y_action)) {
needs$y_action <- identical(mtype, "minimizeActionFragmentation")
}
if (is.null(raw_needs$y_intervention)) {
needs$y_intervention <- identical(mtype, "minimizeInterventionFragmentation")
}
if (is.null(raw_needs$u_intervention)) {
needs$u_intervention <- identical(mtype, "minimizeInterventionImpact")
}
# propagación explícita de metadatos estructurales necesarios
if (isTRUE(needs$y_pu) || isTRUE(needs$y_action) || isTRUE(needs$y_intervention)) {
if (is.null(raw_needs$relation_name)) {
needs$relation_name <- as.character(oargs$relation_name %||% "boundary")[1]
}
}
if (isTRUE(needs$y_action)) {
if (is.null(raw_needs$actions_to_use)) {
needs$actions_to_use <- oargs$actions_to_use %||% oargs$actions %||% NULL
}
}
if (isTRUE(needs$u_intervention)) {
if (is.null(raw_needs$u_intervention_actions)) {
needs$u_intervention_actions <- oargs$actions %||% NULL
}
}
# preserva metadatos extra útiles para MO
extra_fields <- setdiff(names(raw_needs), names(needs))
if (length(extra_fields) > 0L) {
for (nm in extra_fields) {
needs[[nm]] <- raw_needs[[nm]]
}
}
needs$z <- isTRUE(needs$z)
needs$y_pu <- isTRUE(needs$y_pu)
needs$y_action <- isTRUE(needs$y_action)
needs$y_intervention <- isTRUE(needs$y_intervention)
needs$u_intervention <- isTRUE(needs$u_intervention)
x$data$model_args$needs <- needs
x
}
.pa_build_model_prepare_needs_cpp <- function(x) {
stopifnot(inherits(x, "Problem"))
.pa_abort <- function(...) stop(paste0(...), call. = FALSE)
op <- x$data$model_ptr
args <- x$data$model_args %||% list()
needs <- args$needs %||% list()
oargs <- args$objective_args %||% list()
mo_mode <- isTRUE(args$mo_mode)
if (isTRUE(mo_mode) && isTRUE(needs$y_intervention)) {
.pa_abort(
"MO phase 1 does not support preparing y_intervention in the shared superset yet."
)
}
if (!isTRUE(needs$y_pu) &&
!isTRUE(needs$y_action) &&
!isTRUE(needs$y_intervention) &&
!isTRUE(needs$u_intervention)) {
return(x)
}
x$data$model_registry <- x$data$model_registry %||% list()
x$data$model_registry$vars <- x$data$model_registry$vars %||% list()
.pa_prepare_relation_model <- function(rel) {
rel <- rel[, c(
"internal_pu1","internal_pu2","weight",
intersect(names(rel), c("directed","distance","source","relation_name"))
), drop = FALSE]
rel$internal_pu1 <- as.integer(rel$internal_pu1)
rel$internal_pu2 <- as.integer(rel$internal_pu2)
rel$weight <- as.numeric(rel$weight)
rel <- rel[order(rel$internal_pu1, rel$internal_pu2), , drop = FALSE]
rel$internal_edge <- seq_len(nrow(rel))
rel
}
rel_model <- NULL
if (isTRUE(needs$y_pu) ||
isTRUE(needs$y_action) ||
isTRUE(needs$y_intervention)) {
rel_name <- as.character(needs$relation_name %||% oargs$relation_name %||% "boundary")[1]
rels <- x$data$spatial_relations
if (is.null(rels) || is.null(rels[[rel_name]])) {
.pa_abort("prepare_needs: missing spatial relation '", rel_name, "'.")
}
x$data$spatial_relations_model <- x$data$spatial_relations_model %||% list()
if (is.null(x$data$spatial_relations_model[[rel_name]])) {
x$data$spatial_relations_model[[rel_name]] <- .pa_prepare_relation_model(rels[[rel_name]])
}
rel_model <- x$data$spatial_relations_model[[rel_name]]
}
# ---- y_pu
if (isTRUE(needs$y_pu)) {
if (!exists("rcpp_prepare_objective_min_fragmentation", mode = "function")) {
.pa_abort("Missing rcpp_prepare_objective_min_fragmentation() in the package.")
}
res <- rcpp_prepare_objective_min_fragmentation(
x = op,
relation_data = rel_model
)
x$data$model_registry$vars$y_pu <- res
}
# ---- y_action
if (isTRUE(needs$y_action)) {
if (!exists("rcpp_prepare_objective_min_fragmentation_actions", mode = "function")) {
.pa_abort("Missing rcpp_prepare_objective_min_fragmentation_actions() in the package.")
}
if (is.null(x$data$dist_actions_model) || !inherits(x$data$dist_actions_model, "data.frame")) {
.pa_abort("prepare_needs: y_action requires x$data$dist_actions_model (model-ready).")
}
if (nrow(x$data$dist_actions_model) == 0) {
.pa_abort("prepare_needs: y_action requires action variables, but dist_actions_model has 0 rows.")
}
actions_to_use_raw <- needs$actions_to_use %||% oargs$actions_to_use %||% oargs$actions %||% NULL
actions_to_use <- NULL
if (!is.null(actions_to_use_raw)) {
act_subset <- .pa_resolve_action_subset(x, subset = actions_to_use_raw)
actions_to_use <- as.integer(act_subset$internal_id)
}
res <- rcpp_prepare_objective_min_fragmentation_actions(
x = op,
dist_actions_data = x$data$dist_actions_model,
relation_data = rel_model,
actions_to_use = actions_to_use,
block_name = "fragmentation_actions",
tag = ""
)
x$data$model_registry$vars$y_action <- res
}
# ---- u_intervention for min_intervention_impact
if (isTRUE(needs$u_intervention)) {
if (!exists("rcpp_prepare_objective_min_intervention_impact", mode = "function")) {
.pa_abort("Missing rcpp_prepare_objective_min_intervention_impact() in the package.")
}
if (is.null(x$data$dist_actions_model) || !inherits(x$data$dist_actions_model, "data.frame")) {
.pa_abort("prepare_needs: u_intervention requires x$data$dist_actions_model (model-ready).")
}
if (nrow(x$data$dist_actions_model) == 0) {
.pa_abort("prepare_needs: u_intervention requires action variables, but dist_actions_model has 0 rows.")
}
if (is.null(x$data$dist_features) || !inherits(x$data$dist_features, "data.frame")) {
.pa_abort("prepare_needs: u_intervention requires x$data$dist_features.")
}
if (nrow(x$data$dist_features) == 0) {
.pa_abort("prepare_needs: u_intervention requires non-empty x$data$dist_features.")
}
actions_chr <- needs$u_intervention_actions %||% oargs$actions %||% NULL
if (is.null(actions_chr) || length(actions_chr) == 0) {
.pa_abort(
"prepare_needs: u_intervention requires a non-empty shared action subset.\n",
"For MO phase 1, all intervention_impact objectives must use the same actions."
)
}
act_subset <- .pa_resolve_action_subset(x, subset = actions_chr)
acts_internal <- as.integer(act_subset$internal_id)
if (length(acts_internal) == 0) {
.pa_abort("prepare_needs: u_intervention action subset resolved to zero actions.")
}
subset_key <- .pa_subset_to_string(act_subset$id)
impact_col <- as.character(oargs$impact_col %||% "amount")[1]
if (!(impact_col %in% names(x$data$dist_features))) {
impact_col <- "amount"
if (!("amount" %in% names(x$data$dist_features))) {
.pa_abort(
"prepare_needs: could not find a valid impact column in x$data$dist_features."
)
}
}
res <- rcpp_prepare_objective_min_intervention_impact(
x = op,
pu_data = x$data$pu,
dist_actions_data = x$data$dist_actions_model,
dist_features_data = x$data$dist_features,
subset_key = subset_key,
impact_col = impact_col,
features_to_use = integer(0),
actions_to_use = acts_internal,
internal_feature_col = "internal_feature",
block_name = "objective_min_intervention_impact",
tag = if (isTRUE(mo_mode)) "from=prepare_needs_cpp;mode=MO" else ""
)
x$data$model_registry$vars$u_intervention_impact <- res
}
x
}
.pa_deepcopy_data <- function(d) {
# R vectors and data frames use copy-on-modification. Serializing all input
# tables for every setter creates large transient buffers unnecessarily.
# Clone reference objects explicitly; preserve list attributes and scopes.
if (is.environment(d) || isS4(d)) return(unserialize(serialize(d, NULL)))
if (is.list(d) && !is.data.frame(d)) {
out <- lapply(d, .pa_deepcopy_data)
attributes(out) <- attributes(d)
return(out)
}
d
}
.pa_clone_data <- function(x, drop_model = TRUE) {
stopifnot(inherits(x, "Problem"))
# crear un NUEVO proto heredando de x
y <- pproto(NULL, x)
# ahora sí, sustituir data por una copia profunda
d <- x$data
if (isTRUE(drop_model)) {
d$model_ptr <- NULL
d$model_index <- NULL
d$model_list <- NULL
}
y$data <- .pa_deepcopy_data(d)
if (isTRUE(drop_model)) {
y$data$model_ptr <- NULL
y$data$model_index <- NULL
y$data$model_list <- NULL
y$data$has_model <- FALSE
if (is.null(y$data$meta) || !is.list(y$data$meta)) {
y$data$meta <- list()
}
y$data$meta$model_dirty <- TRUE
}
y
}
.pa_log_add <- function(x, key, value) {
stopifnot(inherits(x, "Problem"))
key <- as.character(key)[1]
if (is.na(key) || !nzchar(key)) {
stop("`key` must be a non-empty string.", call. = FALSE)
}
value <- as.numeric(value)[1]
if (!is.finite(value)) {
stop("`value` must be a finite numeric scalar.", call. = FALSE)
}
if (is.null(x$data$build_log) || !is.list(x$data$build_log)) {
x$data$build_log <- list()
}
old <- x$data$build_log[[key]] %||% 0
x$data$build_log[[key]] <- old + value
x
}
.pa_resolve_action_subset <- function(x, subset = NULL) {
stopifnot(inherits(x, "Problem"))
acts <- x$data$actions
if (is.null(acts) || !inherits(acts, "data.frame") || nrow(acts) == 0) {
stop("No actions available in x$data$actions.", call. = FALSE)
}
if (!all(c("id", "internal_id") %in% names(acts))) {
stop("x$data$actions must contain columns 'id' and 'internal_id'.", call. = FALSE)
}
# NULL = all actions
if (is.null(subset)) {
out <- acts[, c("id", "internal_id"), drop = FALSE]
if ("action_set" %in% names(acts)) out$action_set <- acts$action_set
return(out)
}
subset <- as.character(subset)
subset <- unique(subset[!is.na(subset) & nzchar(subset)])
if (length(subset) == 0) {
stop("subset must contain at least one non-empty value, or be NULL.", call. = FALSE)
}
hit_id <- acts$id %in% subset
hit_set <- rep(FALSE, nrow(acts))
if ("action_set" %in% names(acts)) {
hit_set <- acts$action_set %in% subset
}
keep <- hit_id | hit_set
if (!any(keep)) {
stop(
"subset did not match any action ids",
if ("action_set" %in% names(acts)) " or action_set values" else "",
".",
call. = FALSE
)
}
out <- acts[keep, c("id", "internal_id"), drop = FALSE]
if ("action_set" %in% names(acts)) out$action_set <- acts$action_set[keep]
rownames(out) <- NULL
out
}
#' @include internal.R
NULL
# -------------------------------------------------------------------------
# Internal helpers for normalized atomic objectives
# -------------------------------------------------------------------------
.pa_set_active_and_register_objective <- function(
x,
model_type,
objective_id,
objective_args = list(),
sense = c("min", "max"),
alias = NULL
) {
stopifnot(inherits(x, "Problem"))
sense <- match.arg(sense)
single_defined <- isTRUE(x$data$meta$single_objective_defined) ||
(!is.null(x$data$model_args$objective_id) &&
length(x$data$objectives %||% list()) == 0L)
if (is.null(alias) && single_defined) {
stop("A single-objective definition already exists. Use distinct aliases for ",
"multi-objective planning or rebuild from the problem before this objective.",
call. = FALSE)
}
x <- .pa_clone_data(x)
if (is.null(x$data$model_args) || !is.list(x$data$model_args)) {
x$data$model_args <- list()
}
if (is.null(alias) || !single_defined) {
x$data$model_args$model_type <- as.character(model_type)[1]
x$data$model_args$objective_id <- as.character(objective_id)[1]
x$data$model_args$objective_args <- objective_args
}
if (is.null(alias)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$single_objective_defined <- TRUE
}
x <- .pa_register_objective(
x = x,
alias = alias,
objective_id = objective_id,
model_type = model_type,
objective_args = objective_args,
sense = sense
)
x
}
.pa_resolve_feature_subset <- function(x, features = NULL) {
stopifnot(inherits(x, "Problem"))
feats <- x$data$features
if (is.null(feats) || !inherits(feats, "data.frame") || nrow(feats) == 0) {
stop("No features available in x$data$features.", call. = FALSE)
}
if (!all(c("id", "internal_id") %in% names(feats))) {
stop("x$data$features must contain columns 'id' and 'internal_id'.", call. = FALSE)
}
if (is.null(features)) {
out <- feats[, c("id", "internal_id"), drop = FALSE]
if ("name" %in% names(feats)) out$name <- feats$name
return(out)
}
vals <- unique(features)
vals <- vals[!is.na(vals)]
if (length(vals) == 0) {
stop("features must contain at least one non-missing value, or be NULL.", call. = FALSE)
}
hit_id <- feats$id %in% vals
hit_name <- rep(FALSE, nrow(feats))
if ("name" %in% names(feats)) {
hit_name <- as.character(feats$name) %in% as.character(vals)
}
keep <- hit_id | hit_name
if (!any(keep)) {
stop(
"features did not match any feature ids",
if ("name" %in% names(feats)) " or feature names" else "",
".",
call. = FALSE
)
}
out <- feats[keep, c("id", "internal_id"), drop = FALSE]
if ("name" %in% names(feats)) out$name <- feats$name[keep]
rownames(out) <- NULL
out
}
.pa_subset_to_string <- function(subset) {
if (is.null(subset)) return(NA_character_)
subset <- as.character(subset)
subset <- unique(subset[!is.na(subset) & nzchar(subset)])
if (length(subset) == 0) return(NA_character_)
paste(sort(subset), collapse = "|")
}
.pa_add_feature_labels <- function(df,
features_df,
feature_col = "feature",
internal_feature_col = "internal_feature",
out_col = "feature_name") {
stopifnot(is.data.frame(df), is.data.frame(features_df))
if (nrow(df) == 0) {
df[[out_col]] <- character(0)
return(df)
}
if (!("name" %in% names(features_df))) {
df[[out_col]] <- rep(NA_character_, nrow(df))
return(df)
}
out <- rep(NA_character_, nrow(df))
# Prefer external feature id
if (feature_col %in% names(df) && "id" %in% names(features_df)) {
m <- match(df[[feature_col]], features_df$id)
ok <- !is.na(m)
out[ok] <- as.character(features_df$name[m[ok]])
}
# Fill remaining using internal id
if (anyNA(out) &&
internal_feature_col %in% names(df) &&
"internal_id" %in% names(features_df)) {
miss <- which(is.na(out))
m2 <- match(df[[internal_feature_col]][miss], features_df$internal_id)
ok2 <- !is.na(m2)
out[miss[ok2]] <- as.character(features_df$name[m2[ok2]])
}
df[[out_col]] <- out
df
}
.pa_add_action_labels <- function(df,
actions_df,
action_col = "action",
internal_action_col = "internal_action",
out_col = "action_name") {
stopifnot(is.data.frame(df), is.data.frame(actions_df))
if (nrow(df) == 0) {
df[[out_col]] <- character(0)
return(df)
}
if (!("name" %in% names(actions_df))) {
df[[out_col]] <- rep(NA_character_, nrow(df))
return(df)
}
out <- rep(NA_character_, nrow(df))
# Prefer external action id
if (action_col %in% names(df) && "id" %in% names(actions_df)) {
m <- match(df[[action_col]], actions_df$id)
ok <- !is.na(m)
out[ok] <- as.character(actions_df$name[m[ok]])
}
# Fill remaining using internal id
if (anyNA(out) &&
internal_action_col %in% names(df) &&
"internal_id" %in% names(actions_df)) {
miss <- which(is.na(out))
m2 <- match(df[[internal_action_col]][miss], actions_df$internal_id)
ok2 <- !is.na(m2)
out[miss[ok2]] <- as.character(actions_df$name[m2[ok2]])
}
df[[out_col]] <- out
df
}
.pa_solve_single_problem <- function(x, ...) {
assertthat::assert_that(inherits(x, "Problem"))
# ---- gather stored solve args (defaults + stored)
dots <- list(...)
# consideramos “ya configurado” si solve_args existe y tiene al menos un campo no nulo
has_stored_args <- !is.null(x$data$solve_args) &&
length(x$data$solve_args) > 0 &&
any(!vapply(x$data$solve_args, is.null, logical(1)))
sa <- do.call(.pa_get_solve_args, c(list(x = x), dots))
solver <- sa$solver %||% "auto"
gap_limit <- sa$gap_limit
time_limit <- sa$time_limit
solution_limit <- sa$solution_limit
cores <- sa$cores
verbose <- sa$verbose
name_output_file <- sa$name_output_file
output_file <- sa$output_file
solver_params_user <- sa$solver_params %||% list()
# ---- autodetect solver if requested
if (identical(solver, "auto") || identical(solver, "") || is.null(solver)) {
if (requireNamespace("gurobi", quietly = TRUE) &&
isTRUE(available_to_solve("gurobi"))) {
solver <- "gurobi"
} else if (requireNamespace("rcbc", quietly = TRUE) &&
isTRUE(available_to_solve("cbc"))) {
solver <- "cbc"
} else if (requireNamespace("Rcplex", quietly = TRUE) &&
isTRUE(available_to_solve("cplex"))) {
solver <- "cplex"
} else if (requireNamespace("Rsymphony", quietly = TRUE) &&
isTRUE(available_to_solve("symphony"))) {
solver <- "symphony"
} else {
stop("No optimization problem solvers available on this system.", call. = FALSE)
}
} else {
if (!solver %in% c("gurobi", "cbc", "symphony", "cplex")) {
stop("Solver not supported: ", solver, call. = FALSE)
}
if (identical(solver, "gurobi") &&
(!requireNamespace("gurobi", quietly = TRUE) ||
!isTRUE(available_to_solve("gurobi")))) {
stop("Gurobi solver not available (package/license not found).", call. = FALSE)
}
if (identical(solver, "cbc") &&
(!requireNamespace("rcbc", quietly = TRUE) ||
!isTRUE(available_to_solve("cbc")))) {
stop("CBC solver not available (rcbc not installed or CBC not available).", call. = FALSE)
}
if (identical(solver, "symphony") &&
(!requireNamespace("Rsymphony", quietly = TRUE) ||
!isTRUE(available_to_solve("symphony")))) {
stop("SYMPHONY solver not available (Rsymphony not installed).", call. = FALSE)
}
if (identical(solver, "cplex") &&
(!requireNamespace("Rcplex", quietly = TRUE) ||
!isTRUE(available_to_solve("cplex")))) {
stop("CPLEX solver not available (Rcplex not installed/licensed).", call. = FALSE)
}
}
caps <- .pa_apply_solver_capabilities(
solver = solver,
cores = cores,
solution_limit = solution_limit,
output_file = output_file,
name_output_file = name_output_file,
solver_params = solver_params_user,
warn = TRUE
)
cores <- caps$cores
solution_limit <- caps$solution_limit
output_file <- caps$output_file
name_output_file <- caps$name_output_file
solver_params_user <- caps$solver_params
if (identical(solver, "gurobi") &&
isTRUE(output_file) &&
is.null(name_output_file)) {
stop("A non-empty log_file is required when write_log = TRUE.", call. = FALSE)
}
# ---- ensure model is built
if (is.null(x$data$model_ptr) || isTRUE(x$data$meta$model_dirty)) {
x <- .pa_build_model(x)
x$data$meta$model_dirty <- FALSE
}
# ---- model list from pointer
model <- .pa_model_from_ptr(
x$data$model_ptr,
args = x$data$model_args %||% list(),
drop_triplets = TRUE
)
# ---- APPLY SUPERSET RUNTIME UPDATES (solver-agnostic)
model <- .pa_apply_runtime_updates_to_model(model, x)
mo_numeric <- isTRUE(x$data$runtime_updates$mo_numeric)
initial_solution <- x$data$runtime_updates$start
if (!is.null(initial_solution)) {
if (length(initial_solution) != length(model$obj)) {
stop("Runtime initial solution length does not match the model.", call. = FALSE)
}
initial_solution <- as.numeric(initial_solution)
binary <- model$vtype == "B"
initial_solution[binary] <- round(initial_solution[binary])
}
objective_scale <- if (mo_numeric) .pa_positive_objective_scale(model$obj) else 1
model$obj <- model$obj * objective_scale
# Constant ecological objectives can create empty constraint rows. Check
# their feasibility explicitly: some solver adapters omit such rows.
empty_rows <- Matrix::rowSums(abs(model$A)) == 0
impossible <- empty_rows & (
(model$sense == "<=" & model$rhs < 0) |
(model$sense == ">=" & model$rhs > 0) |
(model$sense %in% c("=", "==") & model$rhs != 0)
)
if (any(impossible)) {
stop("Solver status: infeasible (unsatisfied constant constraint).", call. = FALSE)
}
# ---- pack args into Solution metadata
solve_args <- list(
solver = solver,
gap = gap_limit,
timelimit = time_limit,
cores = cores,
verbose = verbose,
solution_limit = solution_limit,
name_output_file = name_output_file,
output_file = output_file,
solver_params = solver_params_user
)
if (mo_numeric) solve_args$objective_scale <- objective_scale
if (!is.null(initial_solution)) solve_args$warm_start <- TRUE
# ------------------------------------------------------------
# 1) Call solver -> return unified payload:
# objval, solvec, gap, status_code, runtime
# ------------------------------------------------------------
objval <- NA_real_
solvec <- numeric(0)
gap <- NA_real_
status_code <- 999L
runtime <- NA_real_
if (solver == "gurobi") {
model$sense <- replace(model$sense, model$sense == "==", "=")
model$lb <- model$bounds$lower$val
model$ub <- model$bounds$upper$val
if (!is.null(initial_solution)) model$start <- initial_solution
params <- list(
LogToConsole = as.integer(verbose),
NodefileStart = 0.5,
MIPGap = gap_limit,
TimeLimit = time_limit
)
if (mo_numeric) {
params <- c(params, list(FeasibilityTol = 1e-9, IntFeasTol = 1e-9,
OptimalityTol = 1e-9, MIPGapAbs = 0))
}
if (!is.null(cores)) params$Threads <- cores
if (isTRUE(output_file)) params$LogFile <- name_output_file
if (isTRUE(solution_limit)) params$SolutionLimit <- 1
if (!is.null(model$args$curve) && !is.null(model$args$segments) && model$args$curve != 1) {
params$FuncPieces <- 1
params$FuncPieceLength <- round(1 / as.numeric(model$args$segments), digits = 1)
}
params <- utils::modifyList(params, solver_params_user)
if (mo_numeric) solve_args$effective_solver_params <- params
sol <- gurobi::gurobi(model, params)
# status_code <- dplyr::case_when(
# sol$status == "OPTIMAL" ~ 0L,
# sol$status %in% c("INF_OR_UNBD", "INFEASIBLE", "UNBOUNDED") ~ 1L,
# (sol$status == "TIME_LIMIT" && !is.null(sol$objval)) ~ 2L,
# (sol$status == "TIME_LIMIT" && is.null(sol$objval)) ~ 3L,
# sol$status == "SOLUTION_LIMIT" ~ 4L,
# TRUE ~ 999L
# )
status_chr <- as.character(sol$status %||% NA_character_)[1]
status_code <- if (identical(status_chr, "OPTIMAL")) {
0L
} else if (status_chr %in% c("INF_OR_UNBD", "INFEASIBLE", "UNBOUNDED")) {
1L
} else if (identical(status_chr, "TIME_LIMIT") && !is.null(sol$objval)) {
2L
} else if (identical(status_chr, "TIME_LIMIT") && is.null(sol$objval)) {
3L
} else if (identical(status_chr, "SOLUTION_LIMIT")) {
4L
} else {
999L
}
objval <- sol$objval %||% NA_real_
solvec <- sol$x %||% numeric(0)
gap <- sol$mipgap %||% NA_real_
runtime <- sol$runtime %||% NA_real_
} else if (solver == "cbc") {
# build row bounds from sense + rhs
row_lb <- rep(-Inf, length(model$rhs))
row_ub <- rep( Inf, length(model$rhs))
ii_le <- which(model$sense == "<=")
ii_ge <- which(model$sense == ">=")
ii_eq <- which(model$sense == "==" | model$sense == "=")
row_ub[ii_le] <- model$rhs[ii_le]
row_lb[ii_ge] <- model$rhs[ii_ge]
row_lb[ii_eq] <- model$rhs[ii_eq]
row_ub[ii_eq] <- model$rhs[ii_eq]
cbc_args <- list(
log = if (isTRUE(verbose)) "1" else "0",
ratio = as.character(gap_limit),
sec = as.character(time_limit),
timem = "elapsed"
)
if (mo_numeric) {
cbc_args <- c(cbc_args, list(primalTolerance = "1e-9",
integerTolerance = "1e-9", dualTolerance = "1e-9"))
}
if (!is.null(cores)) cbc_args$threads <- as.character(cores)
if (isTRUE(solution_limit)) cbc_args$maxso <- "1"
cbc_args <- utils::modifyList(cbc_args, solver_params_user)
if (mo_numeric) solve_args$effective_solver_params <- cbc_args
cbc_matrix <- .pa_cbc_complete_dimensions(
model$A, row_lb, row_ub,
model$bounds$lower$val, model$bounds$upper$val
)
rt <- system.time({
cbc_start <- initial_solution
if (!is.null(cbc_start)) cbc_start[model$vtype != "B"] <- NA_real_
sol_cbc <- rcbc::cbc_solve(
obj = model$obj,
mat = cbc_matrix$mat,
is_integer = ifelse(model$vtype == "B", TRUE, FALSE),
row_ub = cbc_matrix$row_ub,
row_lb = cbc_matrix$row_lb,
col_lb = model$bounds$lower$val,
col_ub = model$bounds$upper$val,
max = ifelse(model$modelsense == "min", FALSE, TRUE),
cbc_args = cbc_args,
initial_solution = cbc_start
)
})
runtime <- rt[[3]]
status_cbc <- rcbc::solution_status(sol_cbc)
status_code <- dplyr::case_when(
status_cbc == "optimal" ~ 0L,
status_cbc == "infeasible" ~ 1L,
(status_cbc == "timelimit" && !is.null(sol_cbc$objective_value)) ~ 2L,
(status_cbc == "timelimit" && is.null(sol_cbc$objective_value)) ~ 3L,
status_cbc == "solutionlimit" ~ 4L,
TRUE ~ 999L
)
objval <- sol_cbc$objective_value %||% NA_real_
solvec <- sol_cbc$column_solution %||% numeric(0)
gap <- if (isTRUE(status_code == 0L)) gap_limit else NA_real_
} else if (solver == "cplex") {
model$lb <- model$bounds$lower$val
model$ub <- model$bounds$upper$val
sense <- model$sense
sense[sense == ">="] <- "G"
sense[sense %in% c("==", "=")] <- "E"
sense[sense == "<="] <- "L"
# Avoid deprecated Matrix coercion inside Rcplex.
if (inherits(model$A, "sparseMatrix")) {
model$A <- methods::as(model$A, "CsparseMatrix")
}
params <- list(
trace = as.integer(verbose),
epgap = gap_limit,
tilim = time_limit
)
params <- utils::modifyList(
params,
solver_params_user
)
rt <- system.time({
sol_cplex <- Rcplex::Rcplex(
cvec = model$obj,
Amat = model$A,
bvec = model$rhs,
lb = model$lb,
ub = model$ub,
objsense = model$modelsense,
sense = sense,
vtype = model$vtype,
control = params
)
})
runtime <- unname(rt[["elapsed"]])
status_cplex <- as.integer(sol_cplex$status)[1]
status_raw <- as.character(status_cplex)
status_code <- if (status_cplex %in% c(1L, 101L, 102L)) {
0L
} else if (status_cplex %in% c(2L, 3L, 4L, 103L, 118L, 119L)) {
1L
} else if (status_cplex %in% c(107L, 111L, 113L, 131L)) {
2L
} else if (status_cplex %in% c(108L, 112L, 114L, 132L)) {
3L
} else if (status_cplex == 104L) {
4L
} else {
999L
}
objval <- sol_cplex$obj %||% NA_real_
solvec <- sol_cplex$xopt %||% numeric(0)
# Rcplex does not expose the final relative MIP gap directly.
# For strict optimality it is zero; for tolerance optimality,
# the accepted tolerance is the best available value.
gap <- if (status_cplex %in% c(1L, 101L)) {
0
} else if (status_cplex == 102L) {
gap_limit
} else {
NA_real_
}
} else if (solver == "symphony") {
max_flag <- ifelse(model$modelsense == "min", FALSE, TRUE)
verbosity <- as.integer(verbose) - 2
rt <- system.time({
sol_sym <- Rsymphony::Rsymphony_solve_LP(
obj = model$obj,
mat = model$A,
dir = model$sense,
rhs = model$rhs,
bounds = model$bounds,
types = model$vtype,
max = max_flag,
gap_limit = gap_limit,
time_limit = time_limit,
verbosity = verbosity,
first_feasible = solution_limit
)
})
runtime <- rt[[3]]
status_code <- dplyr::case_when(
sol_sym$status %in% c(0L, 231L) ~ 0L,
sol_sym$status %in% c(226L, 237L) ~ 1L,
sol_sym$status %in% c(235L, 228L) ~ 2L,
sol_sym$status == 232L ~ 4L,
TRUE ~ 999L
)
objval <- sol_sym$objval %||% NA_real_
solvec <- sol_sym$solution %||% numeric(0)
gap <- if (isTRUE(status_code == 0L)) gap_limit else NA_real_
} else {
stop("Internal error: unknown solver '", solver, "'.", call. = FALSE)
}
# Return the objective in its original units, including AUGMECON's original
# augmentation coefficient. Only the solver-facing copy was rescaled.
objval <- objval / objective_scale
# ------------------------------------------------------------
# Hard fail if solver returned no usable solution
# ------------------------------------------------------------
if (length(solvec) == 0L || all(is.na(solvec))) {
msg <- paste0(
"Solver returned an empty solution vector.\n",
"solver: ", solver, "\n",
"status_code: ", status_code, "\n",
"objval: ", as.character(objval), "\n",
"Possible causes: infeasible model, time limit before first feasible, or solver error.\n",
"Tip: try increasing time_limit, relaxing constraints, or inspect solver logs (if available)."
)
stop(msg, call. = FALSE)
}
# Ensure solution length is consistent with model offsets
n_pu_chk <- as.integer(model$n_pu %||% 0L)
n_x_chk <- as.integer(model$n_x %||% 0L)
n_z_chk <- as.integer(model$n_z %||% 0L)
w0_chk <- as.integer(model$w_offset %||% 0L)
x0_chk <- as.integer(model$x_offset %||% 0L)
z0_chk <- as.integer(model$z_offset %||% 0L)
needed_len <- max(
w0_chk + n_pu_chk,
x0_chk + n_x_chk,
z0_chk + n_z_chk,
0L
)
if (length(solvec) < needed_len) {
stop(
"Solver returned a solution vector of length ", length(solvec),
" but the model requires at least ", needed_len, " variables ",
"(based on offsets + variable counts). ",
"This indicates a mismatch between the built model and the decoded metadata.",
call. = FALSE
)
}
# ------------------------------------------------------------
# 2) Minimal decoding using offsets (0-based in C++; +1 in R)
# ------------------------------------------------------------
# n_pu <- as.integer(model$n_pu %||% 0L)
# n_x <- as.integer(model$n_x %||% 0L)
# n_z <- as.integer(model$n_z %||% 0L)
#
# w0 <- as.integer(model$w_offset %||% 0L)
# x0 <- as.integer(model$x_offset %||% 0L)
# z0 <- as.integer(model$z_offset %||% 0L)
#
# sol_monitoring <- if (n_pu > 0L && length(solvec) >= (w0 + n_pu)) {
# base::round(solvec[(w0 + 1L):(w0 + n_pu)])
# } else numeric(0)
#
# sol_actions <- if (n_x > 0L && length(solvec) >= (x0 + n_x)) {
# base::round(solvec[(x0 + 1L):(x0 + n_x)])
# } else numeric(0)
#
# sol_conservation <- if (n_z > 0L && length(solvec) >= (z0 + n_z)) {
# solvec[(z0 + 1L):(z0 + n_z)]
# } else numeric(0)
# ------------------------------------------------------------
# 3) Build human-readable tables (you implement this helper)
# ------------------------------------------------------------
has_feasible_solution <- status_code %in% c(0L, 2L, 4L)
if (!has_feasible_solution) {
stop(
"Solver did not return a feasible solution.\n",
"solver: ", solver, "\n",
"status_code: ", status_code, "\n",
"status: ", status_cbc %||% "unknown",
call. = FALSE
)
}
summary <- .pa_extract_solution_tables(x, solvec)
x$data$runtime_updates <- NULL
objs <- x$data$objectives %||% list()
alias_values <- NULL
if (is.list(objs) && length(objs) == 1L) {
alias_single <- names(objs)[1]
alias_values <- stats::setNames(objval, alias_single)
}
s <- pproto(
NULL, Solution,
problem = NULL,
solution = list(
objective = objval,
vector = solvec,
alias_values = alias_values
),
summary = summary,
diagnostics = list(
status_code = as.integer(status_code),
gap = gap,
runtime = runtime,
solver = solve_args$solver,
cores = solve_args$cores,
timelimit = solve_args$timelimit,
verbose = solve_args$verbose,
solution_limit = solve_args$solution_limit,
name_output_file = solve_args$name_output_file,
output_file = solve_args$output_file,
solver_args = solve_args
),
method = list(
type = "single"
),
meta = list()
)
s
}
.validate_split_effects <- function(tbl, context = "effects") {
if (!("benefit" %in% names(tbl)) || !("loss" %in% names(tbl))) {
stop("Internal error: .validate_split_effects() requires 'benefit' and 'loss' columns.", call. = FALSE)
}
tbl$benefit <- as.numeric(tbl$benefit)
tbl$loss <- as.numeric(tbl$loss)
#if (na_to_zero) {
tbl$benefit[is.na(tbl$benefit)] <- 0
tbl$loss[is.na(tbl$loss)] <- 0
#}
if (any(tbl$benefit < 0, na.rm = TRUE) || any(tbl$loss < 0, na.rm = TRUE)) {
stop(
context,
": 'benefit' and 'loss' must be non-negative.",
call. = FALSE
)
}
bad <- which(tbl$benefit > 0 & tbl$loss > 0)
if (length(bad) > 0) {
ex <- tbl[bad[1], intersect(c("pu", "action", "feature", "benefit", "loss"), names(tbl)), drop = FALSE]
msg <- paste0(
context,
": a single (pu, action, feature) effect cannot have both positive 'benefit' and positive 'loss'. ",
"This is checked after aggregation by (pu, action, feature), so the same triple cannot contain both gains and damages."
)
if (nrow(ex) == 1) {
msg <- paste0(
msg,
" Example offending row -> pu=", ex$pu,
", action='", ex$action,
"', feature=", ex$feature,
", benefit=", ex$benefit,
", loss=", ex$loss, "."
)
}
stop(msg, call. = FALSE)
}
tbl
}
.pa_model_is_current <- function(x) {
stopifnot(inherits(x, "Problem"))
has_ptr <- !is.null(x$data$model_ptr)
has_list <- !is.null(x$data$model_list) && is.list(x$data$model_list)
dirty <- isTRUE(x$data$meta$model_dirty)
isTRUE(has_ptr && has_list && !dirty)
}
.pa_compile_problem <- function(x, ...) {
.pa_build_model(x)
}
.pa_store_area_constraints <- function(x, area_df) {
stopifnot(inherits(x, "Problem"))
stopifnot(is.data.frame(area_df))
stopifnot(nrow(area_df) >= 1)
required_cols <- c(
"type", "sense", "value", "tolerance",
"unit", "area_col", "actions", "name"
)
miss <- setdiff(required_cols, names(area_df))
if (length(miss) > 0) {
stop(
"Missing required columns in `area_df`: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
if (any(area_df$type != "area")) {
stop("All rows in `area_df` must have `type = 'area'`.", call. = FALSE)
}
if (any(is.na(area_df$sense)) ||
any(!area_df$sense %in% c("min", "max", "equal"))) {
stop(
"`area_df$sense` must contain only 'min', 'max', or 'equal'.",
call. = FALSE
)
}
if (any(!is.finite(area_df$value)) || any(area_df$value < 0)) {
stop(
"`area_df$value` must contain only finite values >= 0.",
call. = FALSE
)
}
if (any(!is.finite(area_df$tolerance)) || any(area_df$tolerance < 0)) {
stop(
"`area_df$tolerance` must contain only finite values >= 0.",
call. = FALSE
)
}
if (any(is.na(area_df$unit)) ||
any(!area_df$unit %in% c("m2", "ha", "km2"))) {
stop(
"`area_df$unit` must contain only 'm2', 'ha', or 'km2'.",
call. = FALSE
)
}
if (any(is.na(area_df$name)) || any(!nzchar(area_df$name))) {
stop(
"`area_df$name` must contain only non-empty character strings.",
call. = FALSE
)
}
area_df$actions <- as.character(area_df$actions)
area_df$area_col <- as.character(area_df$area_col)
area_df$name <- as.character(area_df$name)
area_df$type <- as.character(area_df$type)
area_df$sense <- as.character(area_df$sense)
area_df$unit <- as.character(area_df$unit)
new_actions_key <- ifelse(is.na(area_df$actions), "__ALL__", area_df$actions)
new_key <- paste(new_actions_key, area_df$sense,
ifelse(is.na(area_df$area_col), "__DEFAULT__", area_df$area_col), sep = "||")
if (anyDuplicated(new_key)) {
dup <- unique(new_key[duplicated(new_key)])[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"Duplicated area constraints detected within `area_df` for ",
subset_label,
" and sense = '", sense_key, "'.",
call. = FALSE
)
}
cons <- x$data$constraints %||% list()
old <- cons$area
if (is.null(old)) {
cons$area <- area_df[, required_cols, drop = FALSE]
rownames(cons$area) <- NULL
x$data$constraints <- cons
return(x)
}
if (!is.data.frame(old)) {
stop(
"Stored area constraints must be a data.frame. Please rebuild the problem object.",
call. = FALSE
)
}
old_miss <- setdiff(required_cols, names(old))
if (length(old_miss) > 0) {
stop(
"Stored area constraints are malformed. Missing columns: ",
paste(old_miss, collapse = ", "),
".",
call. = FALSE
)
}
old$actions <- as.character(old$actions)
old$sense <- as.character(old$sense)
old_actions_key <- ifelse(is.na(old$actions), "__ALL__", old$actions)
old_key <- paste(old_actions_key, old$sense,
ifelse(is.na(old$area_col), "__DEFAULT__", old$area_col), sep = "||")
overlap <- intersect(old_key, new_key)
if (length(overlap) > 0) {
dup <- overlap[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"An area constraint already exists for the same subset of actions (",
subset_label,
") and sense = '", sense_key, "'.",
call. = FALSE
)
}
out <- rbind(
old[, required_cols, drop = FALSE],
area_df[, required_cols, drop = FALSE]
)
rownames(out) <- NULL
cons$area <- out
x$data$constraints <- cons
x
}
.pa_store_budget_constraints <- function(x, budget_df) {
stopifnot(inherits(x, "Problem"))
stopifnot(is.data.frame(budget_df))
stopifnot(nrow(budget_df) >= 1)
required_cols <- c(
"type", "sense", "value", "tolerance",
"actions", "include_pu_cost", "include_action_cost", "name"
)
miss <- setdiff(required_cols, names(budget_df))
if (length(miss) > 0) {
stop(
"Missing required columns in `budget_df`: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
if (any(budget_df$type != "budget")) {
stop("All rows in `budget_df` must have `type = 'budget'.", call. = FALSE)
}
if (any(is.na(budget_df$sense)) ||
any(!budget_df$sense %in% c("min", "max", "equal"))) {
stop(
"`budget_df$sense` must contain only 'min', 'max', or 'equal'.",
call. = FALSE
)
}
if (any(!is.finite(budget_df$value)) || any(budget_df$value < 0)) {
stop(
"`budget_df$value` must contain only finite values >= 0.",
call. = FALSE
)
}
if (any(!is.finite(budget_df$tolerance)) || any(budget_df$tolerance < 0)) {
stop(
"`budget_df$tolerance` must contain only finite values >= 0.",
call. = FALSE
)
}
if (!is.logical(budget_df$include_pu_cost) ||
any(is.na(budget_df$include_pu_cost))) {
stop(
"`budget_df$include_pu_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
if (!is.logical(budget_df$include_action_cost) ||
any(is.na(budget_df$include_action_cost))) {
stop(
"`budget_df$include_action_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
if (any(!budget_df$include_pu_cost & !budget_df$include_action_cost)) {
stop(
"Each row in `budget_df` must have at least one of ",
"`include_pu_cost` or `include_action_cost` set to TRUE.",
call. = FALSE
)
}
actions_chr <- as.character(budget_df$actions)
bad_action_pu_mix <- !is.na(actions_chr) & nzchar(actions_chr) & budget_df$include_pu_cost
if (any(bad_action_pu_mix)) {
stop(
"`include_pu_cost = TRUE` is only supported when `actions` is NA/NULL, ",
"because planning-unit costs are not action-specific.",
call. = FALSE
)
}
if (any(is.na(budget_df$name)) || any(!nzchar(budget_df$name))) {
stop(
"`budget_df$name` must contain only non-empty character strings.",
call. = FALSE
)
}
budget_df$type <- as.character(budget_df$type)
budget_df$sense <- as.character(budget_df$sense)
budget_df$actions <- actions_chr
budget_df$name <- as.character(budget_df$name)
new_actions_key <- ifelse(is.na(budget_df$actions), "__ALL__", budget_df$actions)
new_key <- paste(new_actions_key, budget_df$sense, budget_df$include_pu_cost,
budget_df$include_action_cost, sep = "||")
if (anyDuplicated(new_key)) {
dup <- unique(new_key[duplicated(new_key)])[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"Duplicated budget constraints detected within `budget_df` for ",
subset_label,
" and sense = '", sense_key, "'.",
call. = FALSE
)
}
cons <- x$data$constraints %||% list()
old <- cons$budget
if (is.null(old)) {
cons$budget <- budget_df[, required_cols, drop = FALSE]
rownames(cons$budget) <- NULL
x$data$constraints <- cons
return(x)
}
if (!is.data.frame(old)) {
stop(
"Stored budget constraints must be a data.frame. Please rebuild the problem object.",
call. = FALSE
)
}
old_miss <- setdiff(required_cols, names(old))
if (length(old_miss) > 0) {
stop(
"Stored budget constraints are malformed. Missing columns: ",
paste(old_miss, collapse = ", "),
".",
call. = FALSE
)
}
old$type <- as.character(old$type)
old$sense <- as.character(old$sense)
old$actions <- as.character(old$actions)
old$name <- as.character(old$name)
if (any(old$type != "budget")) {
stop(
"Stored budget constraints are malformed: `type` must be 'budget'.",
call. = FALSE
)
}
if (any(is.na(old$sense)) || any(!old$sense %in% c("min", "max", "equal"))) {
stop(
"Stored budget constraints are malformed: invalid values in `sense`.",
call. = FALSE
)
}
if (!is.logical(old$include_pu_cost) || any(is.na(old$include_pu_cost))) {
stop(
"Stored budget constraints are malformed: `include_pu_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
if (!is.logical(old$include_action_cost) || any(is.na(old$include_action_cost))) {
stop(
"Stored budget constraints are malformed: `include_action_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
old_bad_action_pu_mix <- !is.na(old$actions) & nzchar(old$actions) & old$include_pu_cost
if (any(old_bad_action_pu_mix)) {
stop(
"Stored budget constraints are malformed: action-specific rows cannot have `include_pu_cost = TRUE`.",
call. = FALSE
)
}
old_actions_key <- ifelse(is.na(old$actions), "__ALL__", old$actions)
old_key <- paste(old_actions_key, old$sense, old$include_pu_cost,
old$include_action_cost, sep = "||")
overlap <- intersect(old_key, new_key)
if (length(overlap) > 0) {
dup <- overlap[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"A budget constraint already exists for the same subset of actions (",
subset_label,
") and sense = '", sense_key, "'.",
call. = FALSE
)
}
out <- rbind(
old[, required_cols, drop = FALSE],
budget_df[, required_cols, drop = FALSE]
)
rownames(out) <- NULL
cons$budget <- out
x$data$constraints <- cons
x
}
.pa_apply_group_area_constraints_if_present <- function(x) {
stopifnot(inherits(x, "Problem"))
specs <- x$data$constraints$group_area %||% NULL
if (is.null(specs) || nrow(specs) == 0L) {
return(x)
}
if (is.null(x$data$model_ptr)) {
stop(
"Model pointer is missing while applying group-area constraints.",
call. = FALSE
)
}
dist_groups <- x$data$dist_groups
if (is.null(dist_groups) ||
!is.data.frame(dist_groups) ||
nrow(dist_groups) == 0L) {
stop(
"Group-distribution data are missing or empty.",
call. = FALSE
)
}
x <- .pa_refresh_model_snapshot(x)
model_list <- x$data$model_list
x0 <- as.integer(model_list$x_offset)
da <- x$data$dist_actions_model
for (k in seq_len(nrow(specs))) {
spec <- specs[k, , drop = FALSE]
group_id <- spec$group
target <- as.numeric(spec$value)
relative <- isTRUE(spec$relative)
actions_txt <- spec$actions
dg <- dist_groups[
dist_groups$group == group_id,
,
drop = FALSE
]
if (nrow(dg) == 0L) {
stop(
"No group-distribution rows were found for group `",
group_id,
"`.",
call. = FALSE
)
}
available_amount <- sum(dg$amount)
rhs <- if (relative) {
target * available_amount
} else {
target
}
actions_txt <- as.character(actions_txt)[1]
use_all_actions <- (
length(actions_txt) == 0L ||
is.na(actions_txt) ||
!nzchar(trimws(actions_txt)) ||
identical(trimws(actions_txt), "NA")
)
if (use_all_actions) {
da_actions <- da
} else {
actions_chr <- strsplit(
actions_txt,
"\\|"
)[[1]]
actions_chr <- trimws(actions_chr)
actions_chr <- actions_chr[
!is.na(actions_chr) &
nzchar(actions_chr) &
actions_chr != "NA"
]
if (length(actions_chr) == 0L) {
da_actions <- da
} else {
action_subset <- .pa_resolve_action_subset(
x,
subset = actions_chr
)
da_actions <- da[
da$action %in% action_subset$id,
,
drop = FALSE
]
}
}
matched <- merge(
da_actions[
,
c("internal_pu", "internal_row"),
drop = FALSE
],
dg[
,
c("internal_pu", "amount"),
drop = FALSE
],
by = "internal_pu",
all = FALSE,
sort = FALSE
)
if (nrow(matched) == 0L) {
stop(
"No decision variables match group `",
group_id,
"` and the selected actions.",
call. = FALSE
)
}
var_index <- x0 +
as.integer(matched$internal_row) -
1L
coeff <- as.numeric(matched$amount)
cpp_sense <- switch(
spec$sense,
min = ">=",
max = "<=",
equal = "=="
)
x <- .pa_add_linear_constraint(
x = x,
var_index_0based = var_index,
coeff = coeff,
sense = cpp_sense,
rhs = rhs,
name = spec$name,
block_name = "group_area",
tag = as.character(group_id),
refresh_snapshot = FALSE
)
}
x
}
.pa_apply_budget_constraints_if_present <- function(x) {
stopifnot(inherits(x, "Problem"))
cons <- x$data$constraints %||% list()
if (length(cons) == 0L) return(x)
specs <- cons$budget %||% NULL
if (is.null(specs)) return(x)
if (is.null(x$data$model_ptr)) {
stop("Model pointer is missing while applying budget constraints.", call. = FALSE)
}
x <- .pa_refresh_model_snapshot(x)
ml <- x$data$model_list
if (is.null(ml)) {
stop("Model snapshot is missing while applying budget constraints.", call. = FALSE)
}
if (!is.data.frame(specs)) {
stop("Stored budget constraints must be a data.frame.", call. = FALSE)
}
required_cols <- c(
"type", "sense", "value", "tolerance",
"actions", "include_pu_cost", "include_action_cost", "name"
)
miss <- setdiff(required_cols, names(specs))
if (length(miss) > 0) {
stop(
"Stored budget constraints are malformed. Missing columns: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
n_pu <- as.integer(ml$n_pu %||% 0L)
if (n_pu <= 0L) {
stop("Model has n_pu=0; cannot apply budget constraints.", call. = FALSE)
}
da <- x$data$dist_actions_model %||% NULL
if (is.null(da) || !is.data.frame(da) || nrow(da) == 0L) {
stop(
"Budget constraints require `x$data$dist_actions_model`.",
call. = FALSE
)
}
if (!("internal_row" %in% names(da))) {
stop(
"`dist_actions_model` must contain column `internal_row`.",
call. = FALSE
)
}
if (!("cost" %in% names(da))) {
stop(
"`dist_actions_model` must contain column `cost`.",
call. = FALSE
)
}
x0 <- as.integer(ml$x_offset %||% 0L)
w0 <- as.integer(ml$w_offset %||% 0L)
for (k in seq_len(nrow(specs))) {
spec <- specs[k, , drop = FALSE]
sense <- as.character(spec$sense)[1]
rhs <- as.numeric(spec$value)[1]
tol <- as.numeric(spec$tolerance)[1]
nm <- as.character(spec$name)[1]
actions_txt <- as.character(spec$actions)[1]
include_pu_cost <- isTRUE(spec$include_pu_cost[[1]])
include_action_cost <- isTRUE(spec$include_action_cost[[1]])
if (!sense %in% c("min", "max", "equal")) {
stop("Unknown budget constraint sense: ", sense, call. = FALSE)
}
if (!is.finite(rhs) || is.na(rhs) || rhs < 0) {
stop("Invalid budget constraint value in stored budget constraints.", call. = FALSE)
}
if (!is.finite(tol) || is.na(tol) || tol < 0) {
stop("Invalid budget constraint tolerance in stored budget constraints.", call. = FALSE)
}
if (is.na(nm) || !nzchar(nm)) {
stop("Stored budget constraint has invalid `name`.", call. = FALSE)
}
if (!include_pu_cost && !include_action_cost) {
stop(
"Stored budget constraint `", nm,
"` has both `include_pu_cost` and `include_action_cost` set to FALSE.",
call. = FALSE
)
}
var_index <- integer(0)
coeff <- numeric(0)
# ------------------------------------------------------------
# planning-unit cost component (only for global budget)
# ------------------------------------------------------------
if (include_pu_cost) {
if (!is.na(actions_txt) && nzchar(actions_txt)) {
stop(
"Stored budget constraint `", nm,
"` has `include_pu_cost = TRUE` with an action-specific subset, which is not supported.",
call. = FALSE
)
}
pu_cost <- .pa_get_cost_vec(x$data$pu)
if (length(pu_cost) != n_pu) {
stop(
"Planning-unit cost vector length (", length(pu_cost), ") != n_pu (", n_pu,
") while applying budget constraint `", nm, "`.",
call. = FALSE
)
}
j0_w <- w0 + (0:(n_pu - 1L))
var_index <- c(var_index, j0_w)
coeff <- c(coeff, as.numeric(pu_cost))
}
# ------------------------------------------------------------
# action cost component
# ------------------------------------------------------------
if (include_action_cost) {
keep <- rep(TRUE, nrow(da))
if (!is.na(actions_txt) && nzchar(actions_txt)) {
actions_chr <- strsplit(actions_txt, "\\|", fixed = FALSE)[[1]]
act_subset <- .pa_resolve_action_subset(x, subset = actions_chr)
if (!is.data.frame(act_subset) || nrow(act_subset) == 0L) {
stop(
"Stored budget constraint `", nm,
"` refers to an invalid or empty action subset.",
call. = FALSE
)
}
keep <- da$action %in% act_subset$id
}
if (!any(keep)) {
stop(
"Stored budget constraint `", nm,
"` does not match any rows in `dist_actions_model`.",
call. = FALSE
)
}
var_index_x <- x0 + (as.integer(da$internal_row[keep]) - 1L)
coeff_x <- as.numeric(da$cost[keep])
if (length(var_index_x) != length(coeff_x) || length(coeff_x) == 0L) {
stop(
"Failed to assemble action-cost coefficients for budget constraint `", nm, "`.",
call. = FALSE
)
}
var_index <- c(var_index, var_index_x)
coeff <- c(coeff, coeff_x)
}
if (length(var_index) != length(coeff) || length(coeff) == 0L) {
stop(
"Failed to assemble coefficients for budget constraint `", nm, "`.",
call. = FALSE
)
}
if (identical(sense, "min")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs,
name = nm
)
} else if (identical(sense, "max")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs,
name = nm
)
} else if (identical(sense, "equal")) {
if (tol == 0) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "==",
rhs = rhs,
name = nm
)
} else {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs - tol,
name = paste0(nm, "_lower")
)
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs + tol,
name = paste0(nm, "_upper")
)
}
}
}
x
}
.pa_active_objective_alias <- function(x) {
objs <- x$data$objectives
if (is.null(objs) || !is.list(objs) || length(objs) == 0) {
return(NULL)
}
args <- x$data$model_args %||% list()
mtype <- args$model_type %||% NULL
oid <- args$objective_id %||% NULL
for (nm in names(objs)) {
ob <- objs[[nm]]
same_mtype <- !is.null(mtype) &&
identical(as.character(ob$model_type)[1], as.character(mtype)[1])
same_oid <- !is.null(oid) &&
identical(as.character(ob$objective_id)[1], as.character(oid)[1])
if (isTRUE(same_mtype) || isTRUE(same_oid)) {
return(ob$alias %||% nm)
}
}
NULL
}
.pa_feature_names_from_internal_ids <- function(x, ids) {
ids <- as.integer(ids)
f <- x$data$features
if (is.null(f) || !inherits(f, "data.frame") || nrow(f) == 0) {
return(as.character(ids))
}
label_col <- if ("name" %in% names(f)) {
"name"
} else if ("id" %in% names(f)) {
"id"
} else {
NULL
}
if (is.null(label_col) || !("internal_id" %in% names(f))) {
return(as.character(ids))
}
out <- as.character(f[[label_col]][match(ids, f$internal_id)])
out[is.na(out)] <- as.character(ids[is.na(out)])
out
}
.pa_action_names_from_internal_ids <- function(x, ids) {
ids <- as.integer(ids)
a <- x$data$actions
if (is.null(a) || !inherits(a, "data.frame") || nrow(a) == 0) {
return(as.character(ids))
}
label_col <- if ("name" %in% names(a)) {
"name"
} else if ("id" %in% names(a)) {
"id"
} else {
NULL
}
if (is.null(label_col) || !("internal_id" %in% names(a))) {
return(as.character(ids))
}
out <- as.character(a[[label_col]][match(ids, a$internal_id)])
out[is.na(out)] <- as.character(ids[is.na(out)])
out
}
#' Prepare an objective matrix for internal multi-objective operations
#'
#' @noRd
.pa_get_objective_matrix <- function(x,
objectives = NULL,
minimize = TRUE,
drop_na = TRUE,
minimum_objectives = 2L) {
if (!inherits(x, "SolutionSet")) {
stop("x must be a SolutionSet object.", call. = FALSE)
}
if (
length(minimum_objectives) != 1L ||
!is.numeric(minimum_objectives) ||
is.na(minimum_objectives) ||
!is.finite(minimum_objectives) ||
minimum_objectives < 1L ||
minimum_objectives != floor(minimum_objectives)
) {
stop(
"Internal error: `minimum_objectives` must be a positive integer.",
call. = FALSE
)
}
minimum_objectives <- as.integer(minimum_objectives)
vals <- .pa_get_objectives_internal(
x,
format = "wide"
)
if (!inherits(vals, "data.frame") || nrow(vals) == 0L) {
stop("No objective values are available.", call. = FALSE)
}
if (!("run_id" %in% names(vals))) {
stop("Objective table must contain a 'run_id' column.", call. = FALSE)
}
if (!("solution_id" %in% names(vals))) {
vals$solution_id <- NA_integer_
}
available <- setdiff(names(vals), c("run_id", "solution_id"))
if (length(available) == 0L) {
stop("No objective columns found.", call. = FALSE)
}
if (is.null(objectives)) {
objectives <- available
} else {
objectives <- as.character(objectives)
objectives <- objectives[!is.na(objectives) & nzchar(objectives)]
if (length(objectives) == 0L) {
stop("`objectives` must contain at least one objective name.", call. = FALSE)
}
bad <- setdiff(objectives, available)
if (length(bad) > 0L) {
stop(
"Unknown objective(s): ",
paste(bad, collapse = ", "),
". Available objectives are: ",
paste(available, collapse = ", "),
".",
call. = FALSE
)
}
}
if (length(objectives) < minimum_objectives) {
objective_word <- if (minimum_objectives == 1L) {
"one objective is"
} else if (minimum_objectives == 2L) {
"two objectives are"
} else {
paste0(minimum_objectives, " objectives are")
}
stop(
"At least ",
objective_word,
" required to evaluate dominance.",
call. = FALSE
)
}
mat <- as.matrix(vals[, objectives, drop = FALSE])
storage.mode(mat) <- "double"
if (isTRUE(drop_na)) {
ok <- stats::complete.cases(mat)
vals <- vals[ok, , drop = FALSE]
mat <- mat[ok, , drop = FALSE]
}
if (nrow(mat) == 0L) {
stop("No complete objective rows are available.", call. = FALSE)
}
specs <- get_objective_specs(x)
if (!all(c("objective", "sense") %in% names(specs))) {
stop(
"Objective specifications must contain 'objective' and 'sense' columns.",
call. = FALSE
)
}
sense <- stats::setNames(as.character(specs$sense), specs$objective)
sense <- sense[objectives]
if (anyNA(sense) || any(!nzchar(sense))) {
missing <- objectives[is.na(sense) | !nzchar(sense)]
stop(
"Missing optimization sense for objective(s): ",
paste(missing, collapse = ", "),
".",
call. = FALSE
)
}
if (!all(sense %in% c("min", "max"))) {
bad <- objectives[!sense %in% c("min", "max")]
stop(
"Invalid optimization sense for objective(s): ",
paste(bad, collapse = ", "),
". Expected 'min' or 'max'.",
call. = FALSE
)
}
if (isTRUE(minimize)) {
max_cols <- which(sense == "max")
if (length(max_cols) > 0L) {
mat[, max_cols] <- -mat[, max_cols, drop = FALSE]
}
}
row_ids <- vals$solution_id
missing_solution_id <- is.na(row_ids)
if (any(missing_solution_id)) {
row_ids[missing_solution_id] <- paste0("run_", vals$run_id[missing_solution_id])
}
rownames(mat) <- row_ids
list(
run_id = vals$run_id,
solution_id = vals$solution_id,
objectives = objectives,
sense = sense,
minimize = isTRUE(minimize),
matrix = mat
)
}
.pa_get_objectives_internal <- function(x,
format = c("wide", "long")) {
format <- match.arg(format)
runs <- x$solution$runs %||% NULL
if (is.null(runs) || !inherits(runs, "data.frame")) {
stop("No run table found in x$solution$runs.", call. = FALSE)
}
value_cols <- grep("^value_", names(runs), value = TRUE)
if (length(value_cols) == 0L) {
stop(
"No objective value columns found in the internal run table. ",
"Expected columns named 'value_<objective>'.",
call. = FALSE
)
}
if (!("run_id" %in% names(runs))) {
runs$run_id <- seq_len(nrow(runs))
}
runs$run_id <- as.integer(runs$run_id)
if (!("solution_id" %in% names(runs))) {
runs$solution_id <- NA_integer_
} else {
runs$solution_id <- suppressWarnings(as.integer(runs$solution_id))
}
objectives <- sub("^value_", "", value_cols)
if (identical(format, "wide")) {
out <- runs[, c("run_id", "solution_id", value_cols), drop = FALSE]
names(out) <- c("run_id", "solution_id", objectives)
rownames(out) <- NULL
return(out)
}
out <- do.call(
rbind,
lapply(seq_along(value_cols), function(i) {
data.frame(
run_id = runs$run_id,
solution_id = runs$solution_id,
objective = objectives[i],
value = as.numeric(runs[[value_cols[i]]]),
stringsAsFactors = FALSE
)
})
)
rownames(out) <- NULL
out
}
.pa_validate_positive_integer_ids <- function(
x,
argument = "id",
scalar = FALSE
) {
if (isTRUE(scalar) && length(x) != 1L) {
stop("`", argument, "` must be a single positive integer.", call. = FALSE)
}
if (length(x) == 0L) {
stop("`", argument, "` must contain at least one positive integer.", call. = FALSE)
}
if (!is.numeric(x) || is.logical(x)) {
stop("`", argument, "` must contain numeric positive integers.", call. = FALSE)
}
invalid_missing <- is.na(x)
present <- !is.na(x)
if (
any(invalid_missing) ||
any(!is.finite(x[present])) ||
any(x[present] < 1) ||
any(x[present] != floor(x[present])) ||
any(x[present] > .Machine$integer.max)
) {
stop("`", argument, "` must contain positive integers.", call. = FALSE)
}
out <- rep(NA_integer_, length(x))
out[present] <- as.integer(x[present])
out
}
.pa_as_int_id <- function(x, what = "id") {
if (is.factor(x)) {
x <- as.character(x)
}
if (is.character(x)) {
x <- trimws(x)
if (anyNA(x) || any(!nzchar(x))) {
stop("`", what, "` must not contain NA or empty values.", call. = FALSE)
}
ok <- grepl("^[-+]?[0-9]+$", x)
if (!all(ok)) {
bad <- unique(x[!ok])
stop(
"`", what, "` must contain integer-like ids. ",
"Character ids with non-numeric symbols are not currently supported. ",
"Problematic values: ",
paste(utils::head(bad, 20), collapse = ", "),
if (length(bad) > 20) " ..." else "",
call. = FALSE
)
}
out <- suppressWarnings(as.integer(x))
} else if (is.numeric(x) || is.integer(x)) {
if (anyNA(x) || any(!is.finite(x))) {
stop("`", what, "` must not contain NA or non-finite values.", call. = FALSE)
}
if (any(abs(x - round(x)) > .Machine$double.eps^0.5)) {
stop("`", what, "` must contain integer-like numeric values.", call. = FALSE)
}
out <- as.integer(round(x))
} else {
stop("`", what, "` must be integer-like.", call. = FALSE)
}
if (anyNA(out)) {
stop("`", what, "` contains values that cannot be converted to integer.", call. = FALSE)
}
out
}
Try the multiscape package in your browser
Any scripts or data that you put into this service are public.
multiscape documentation built on Oct. 12, 2026, 5:08 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .pa_as_int_id .pa_validate_positive_integer_ids .pa_get_objectives_internal .pa_get_objective_matrix .pa_action_names_from_internal_ids .pa_feature_names_from_internal_ids .pa_active_objective_alias .pa_apply_budget_constraints_if_present .pa_apply_group_area_constraints_if_present .pa_store_budget_constraints .pa_store_area_constraints .pa_compile_problem .pa_model_is_current .validate_split_effects .pa_solve_single_problem .pa_add_action_labels .pa_add_feature_labels .pa_subset_to_string .pa_resolve_feature_subset .pa_set_active_and_register_objective .pa_resolve_action_subset .pa_log_add .pa_clone_data .pa_deepcopy_data .pa_build_model_prepare_needs_cpp .pa_build_model_set_needs_from_objective .pa_build_model_init_needs .pa_needs_default .pa_swap_edges .pa_rbind_fill .pa_get_pu_sf_aligned .pa_coords_from_input .pa_store_relation .pa_ensure_pu_index .pa_has_sf .pa_fast_extract .pa_register_objective .pa_create_problem_tabular_impl .pa_apply_runtime_updates_to_model .pa_abort .pa_model_frag_vars_summary .pa_action_weights_vector .pa_validate_relation .pa_add_linear_constraint .pa_ensure_model_snapshot .pa_get_area_vec .pa_extract_solution_tables .pa_apply_solver_capabilities .pa_get_solve_args .pa_spatial_relations_summary .pa_has_coords .is_raster_path `%||%` .pa_model_dims .pa_has_model .pa_nrow0 .pa_get_action_cost_vec .pa_get_cost_vec .pa_safe_range .pa_cli_box_chars .pa_cli_theme .pa_model_from_ptr .pa_positive_objective_scale .pa_cbc_complete_dimensions .pa_apply_area_constraints_if_present .pa_refresh_model_snapshot .pa_apply_targets_if_present .get_dist_effects_model .get_dist_benefit_model_from_effects .pa_feature_potential .pa_feature_totals .pa_store_targets .pa_constraint_name .pa_target_actions .pa_assert_unconfigured .pa_parse_targets available_to_solve getStatus pproto no_extra_arguments
#' No extra arguments
#'
#' Check that no additional unused arguments have been supplied to a function
#' through the `...`.
#'
#' @param ... arguments that are not used.
#'
#' @return `logical` indicating success.
#'
#' @noRd
no_extra_arguments <- function(...) {
return(length(list(...)) == 0)
}
assertthat::on_failure(no_extra_arguments) <- function(call, env) {
"unused arguments"
}
#' Create a new `pproto` object
#'
#' Construct a new object with `pproto`. This object system is inspired
#' from the `ggproto` system used in the `ggplot2` package.
#'
#' @param _class Class name to assign to the object. This is stored as the class
#' attribute of the object. This is optional: if `NULL` (the default),
#' no class name will be added to the object.
#'
#' @param _inherit `pproto` object to inherit from. If `NULL`, don"t
#' inherit from any object.
#'
#' @param ... A list of members to add to the new `pproto` object.
#'
#' @examples
#' Adder <- pproto("Adder",
#' x = 0,
#' add = function(self, n) {
#' self$x <- self$x + n
#' self$x
#' }
#' )
#'
#' Adder$add(10)
#' Adder$add(10)
#'
#' Abacus <- pproto("Abacus", Adder,
#' subtract = function(self, n) {
#' self$x <- self$x - n
#' self$x
#' }
#' )
#' Abacus$add(10)
#' Abacus$subtract(10)
#' @noRd
pproto <- function(`_class` = NULL, `_inherit` = NULL, ...) {
assertthat::assert_that(
assertthat::is.string(`_class`) || is.null(`_class`),
inherits(`_inherit`, "pproto") || is.null(`_inherit`)
)
# Create proto object without retaining the caller frame.
# proto::proto() defaults to envir = new.env(parent = parent.frame()),
# which can capture large temporary objects from pproto()/assign_fields().
#
# Use the package namespace as the parent environment so proto methods can
# still find internal helpers such as .pa_cli_box_chars().
new_proto <- function(...) {
ns <- environment(pproto)
proto::proto(
envir = new.env(parent = ns),
funEnvir = ns,
...
)
}
# copy objects from one proto to another proto
assign_fields <- function(p1, p2) {
if (!inherits(p2, "proto")) {
return()
}
for (i in p2$ls()) {
if (inherits(p2[[i]], "proto")) {
p1[[i]] <- new_proto()
class(p1[[i]]) <- class(p2[[i]])
assign_fields(p1[[i]], p2[[i]])
} else {
p1[[i]] <- p2[[i]]
}
}
assign_fields(p1, p2$.super)
}
# create new proto without retaining the caller frame
p <- new_proto()
if (!is.null(`_inherit`)) {
assign_fields(p, `_inherit`)
class(p) <- class(`_inherit`)
} else {
class(p) <- c("pproto", class(p))
}
# assign members to new proto without retaining the caller frame
dots <- new_proto(...)
assign_fields(p, dots)
if (!is.null(`_class`)) {
class(p) <- c(`_class`, class(p))
}
p
}
#' Get status
#'
#' Construct a new object with `pproto`. This object system is inspired
#' from the `ggproto` system used in the `ggplot2` package.
#'
#' @param _class Class name to assign to the object. This is stored as the class
#' attribute of the object. This is optional: if `NULL` (the default),
#' no class name will be added to the object.
#'
#' @param _inherit `pproto` object to inherit from. If `NULL`, don"t
#' inherit from any object.
#'
#' @param ... A list of members to add to the new `pproto` object.
#'
#' @noRd
getStatus <- function(x) {
# Preferred structure: Solution with diagnostics
d <- NULL
if (!is.null(x$diagnostics)) {
d <- x$diagnostics
} else {
d <- x
}
code <- d$status_code %||% d$status %||% NA_integer_
code <- as.integer(code)[1]
if (is.na(code)) return("unknown")
switch(
as.character(code),
"0" = "optimal",
"1" = "infeasible_or_unbounded",
"2" = "time_limit_feasible",
"3" = "time_limit_no_solution",
"4" = "solution_limit",
"999" = "unknown",
paste0("unknown(", code, ")")
)
}
#' Check if solvers are working
#'
#' Provides the status of solver. Being TRUE if it's working fine and FALSE in otherwise.
#'
#' @param package `character` object. Posible values: "gurobi", "cplex", and "symphony".
#'
#' @examples
#' available_to_solve("cplex")
#'
#' @noRd
available_to_solve <- function(package = ""){
# define primitive data
nPlants <- 1
nWarehouses <- 1
# Warehouse demand in thousands of units
Demand <- c(10)
# Plant capacity in thousands of units
Capacity <- c(20)
# Fixed costs for each plant
FixedCosts <- c(100)
# Transportation costs per thousand units
TransCosts <- c(100)
flowidx <- function(w, p) {nPlants * (w-1) + p}
# Build model
model <- list()
model$modelname <- 'facility'
model$modelsense <- 'min'
# initialize data for variables
model$lb <- 0
model$ub <- c(rep(1, nPlants), rep(Inf, nPlants * nWarehouses))
model$vtype <- c(rep('B', nPlants), rep('C', nPlants * nWarehouses))
model$obj <- c(FixedCosts, TransCosts)
model$varnames <- c(paste0(rep('Open',nPlants),1:nPlants),
sprintf('Trans%d,%d',
c(mapply(rep,1:nWarehouses,nPlants)),
1:nPlants))
# build production constraint matrix
A1 <- Matrix::spMatrix(nPlants, nPlants, i = c(1:nPlants), j = (1:nPlants), x = -Capacity)
A2 <- Matrix::spMatrix(nPlants, nPlants * nWarehouses,
i = c(mapply(rep, 1:nPlants, nWarehouses)),
j = mapply(flowidx,1:nWarehouses,c(mapply(rep,1:nPlants,nWarehouses))),
x = rep(1, nWarehouses * nPlants))
A3 <- Matrix::spMatrix(nWarehouses, nPlants)
A4 <- Matrix::spMatrix(nWarehouses, nPlants * nWarehouses,
i = c(mapply(rep, 1:nWarehouses, nPlants)),
j = mapply(flowidx,c(mapply(rep,1:nWarehouses,nPlants)),1:nPlants),
x = rep(1, nPlants * nWarehouses))
model$A <- rbind(cbind(A1, A2), cbind(A3, A4))
model$rhs <- c(rep(0, nPlants), Demand)
model$sense <- c(rep('<=', nPlants), rep('==', nWarehouses))
model$constrnames <- c(sprintf('Capacity%d',1:nPlants),
sprintf('Demand%d',1:nWarehouses))
if(package == "gurobi"){
# set parameters
params <- list()
params$TimeLimit <- 0.01
params$LogToConsole <- 0
model$sense <- replace(model$sense, model$sense == "==", "=")
sol <- invisible(try(gurobi::gurobi(model, params), silent = TRUE))
}
else if(package == "cbc"){
# set parameters
cbc_args <- list()
cbc_args$sec <- "0.01"
cbc_args$log <- "0"
constraints_minus_equal <- which(model$sense != "<=")
constraints_plus_equal <- which(model$sense == "<=")
row_ub <- model$rhs
row_ub[constraints_minus_equal] <- Inf
row_lb <- model$rhs
row_lb[constraints_plus_equal] <- -Inf
sol <- invisible(try(rcbc::cbc_solve(obj = model$obj,
mat = model$A,
is_integer = ifelse(model$vtype == "B", TRUE, FALSE),
row_ub = row_ub,
row_lb = row_lb,
col_lb = rep(0, length(model$vtype)),
col_ub = model$ub,
max = ifelse(model$modelsense == "min", FALSE, TRUE),
cbc_args = cbc_args), silent = TRUE))
}
else if(package == "cplex"){
model$sense[model$sense == ">="] <- "G"
model$sense[model$sense == "=="] <- "E"
model$sense[model$sense == "<="] <- "L"
# set parameters
params <- list()
params$tilim <- 0.01
params$trace <- 0
sol <- try(Rcplex::Rcplex(cvec = model$obj,
Amat = model$A,
bvec = model$rhs,
lb = model$lb,
ub = model$ub,
objsense = model$modelsense,
sense = model$sense,
vtype = model$vtype,
control = params),
silent = TRUE)
}
else if(package == "symphony"){
model$mat <- model$A
model$dir <- model$sense
model$max <- ifelse(model$modelsense == "min", FALSE, TRUE)
model$types <- model$vtype
sol <- invisible(try(Rsymphony::Rsymphony_solve_LP(model$obj,
model$mat,
model$dir,
model$rhs,
model$bounds,
model$types,
model$max,
gap_limit = 100,
time_limit = 0.01),
silent = TRUE))
}
if(inherits(sol, "try-error")){
return(FALSE)
}
else{
return(TRUE)
}
}
# -------------------------------------------------------------------------
# Internal helpers TARGETS
# -------------------------------------------------------------------------
.pa_parse_targets <- function(x, targets, features = NULL) {
feats <- x$data$features
if (is.null(feats) || nrow(feats) == 0) {
stop("x$data$features is missing/empty.", call. = FALSE)
}
if (!("id" %in% names(feats))) {
stop("x$data$features must contain column 'id'.", call. = FALSE)
}
feat_ids <- as.numeric(feats$id)
feat_names <- if ("name" %in% names(feats)) as.character(feats$name) else rep(NA_character_, length(feat_ids))
.feature_name_from_id <- function(fid) {
fid <- as.numeric(fid)
feat_names[match(fid, feat_ids)]
}
# helper: map a feature identifier (id or name) to numeric id
.map_feature <- function(v) {
if (is.null(v)) return(NULL)
if (is.factor(v)) v <- as.character(v)
if (is.numeric(v) || is.integer(v)) {
v <- as.numeric(v)
bad <- v[!v %in% feat_ids]
if (length(bad) > 0) {
stop("Unknown feature id(s): ", paste(unique(bad), collapse = ", "), call. = FALSE)
}
return(v)
}
if (is.character(v)) {
sup <- suppressWarnings(as.numeric(v))
is_numlike <- !is.na(sup) & nzchar(v)
out <- rep(NA_real_, length(v))
if (any(is_numlike)) {
vv <- sup[is_numlike]
bad <- vv[!vv %in% feat_ids]
if (length(bad) == 0) out[is_numlike] <- vv
}
need_name <- is.na(out)
if (any(need_name)) {
if (!("name" %in% names(feats))) {
stop("Targets reference feature names, but x$data$features has no 'name' column.", call. = FALSE)
}
m <- match(v[need_name], feat_names)
bad <- v[need_name][is.na(m)]
if (length(bad) > 0) {
stop(
"Unknown feature name(s): ", paste0("'", unique(bad), "'", collapse = ", "),
". Valid names include: ", paste0("'", utils::head(feat_names, 10), "'", collapse = ", "),
if (length(feat_names) > 10) " ..." else "",
call. = FALSE
)
}
out[need_name] <- feat_ids[m]
}
return(as.numeric(out))
}
stop("Unsupported feature identifier type.", call. = FALSE)
}
.resolve_target_features <- function(features) {
if (is.null(features)) return(feat_ids)
f <- .map_feature(features)
if (length(f) == 0) {
stop("features resolved to an empty set.", call. = FALSE)
}
f <- unique(as.numeric(f))
f
}
.finalize_targets <- function(f, t) {
dt <- data.frame(
feature = as.numeric(f),
feature_name = .feature_name_from_id(f),
target_raw = as.numeric(t),
stringsAsFactors = FALSE
)
dt <- dt[order(dt$feature), , drop = FALSE]
if (anyDuplicated(dt$feature)) {
stop("Duplicate targets for the same feature. Please de-duplicate.", call. = FALSE)
}
dt
}
selected_features <- .resolve_target_features(features)
# 1) data.frame(feature, target)
if (inherits(targets, "data.frame")) {
if (!all(c("feature", "target") %in% names(targets))) {
stop("If targets is a data.frame it must contain columns 'feature' and 'target'.", call. = FALSE)
}
if (!is.null(features)) {
warning(
"'features' was supplied but targets is a data.frame with an explicit 'feature' column. ",
"Ignoring 'features'.",
call. = FALSE
)
}
f <- .map_feature(targets$feature)
t <- as.numeric(targets$target)
if (any(is.na(t))) stop("Targets contain NA values.", call. = FALSE)
return(.finalize_targets(f, t))
}
# 2) matrix (one column) with optional rownames
if (is.matrix(targets)) {
if (ncol(targets) != 1) {
stop("If targets is a matrix it must have exactly 1 column.", call. = FALSE)
}
t <- as.numeric(targets[, 1])
if (any(is.na(t))) stop("Targets contain NA values.", call. = FALSE)
rn <- rownames(targets)
if (!is.null(rn) && length(rn) == length(t)) {
if (!is.null(features)) {
warning(
"'features' was supplied but targets is a matrix with rownames. Ignoring 'features'.",
call. = FALSE
)
}
f <- .map_feature(rn)
return(.finalize_targets(f, t))
}
if (length(t) == 1) {
return(.finalize_targets(selected_features, rep(t, length(selected_features))))
}
if (length(t) != length(selected_features)) {
stop(
"Matrix targets without rownames must have nrow = 1 or nrow = number of targeted features (",
length(selected_features), ").",
call. = FALSE
)
}
return(.finalize_targets(selected_features, t))
}
# 3) scalar numeric -> recycle
if (is.numeric(targets) && length(targets) == 1) {
t <- as.numeric(targets)
if (is.na(t)) stop("Target is NA.", call. = FALSE)
return(.finalize_targets(selected_features, rep(t, length(selected_features))))
}
# 4) numeric vector
if (is.numeric(targets) && length(targets) > 1) {
t <- as.numeric(targets)
if (any(is.na(t))) stop("Targets contain NA values.", call. = FALSE)
nm <- names(targets)
if (!is.null(nm) && any(nzchar(nm))) {
if (!is.null(features)) {
warning(
"'features' was supplied but targets is a named vector. Ignoring 'features'.",
call. = FALSE
)
}
f <- .map_feature(nm)
return(.finalize_targets(f, t))
}
if (length(t) != length(selected_features)) {
stop(
"Un-named numeric targets must have length 1 or length equal to the number of targeted features (",
length(selected_features), ").",
call. = FALSE
)
}
return(.finalize_targets(selected_features, t))
}
# 5) character
if (is.character(targets)) {
if (length(targets) == 1 && grepl("^\\s*[-+]?[0-9]*\\.?[0-9]+\\s*$", targets)) {
t <- as.numeric(targets)
return(.finalize_targets(selected_features, rep(t, length(selected_features))))
}
if (any(grepl("=", targets, fixed = TRUE))) {
if (!is.null(features)) {
warning(
"'features' was supplied but targets uses 'feature=target' syntax. Ignoring 'features'.",
call. = FALSE
)
}
parts <- strsplit(targets, "=", fixed = TRUE)
feat_part <- vapply(parts, `[[`, character(1), 1)
val_part <- vapply(parts, `[[`, character(1), 2)
f <- .map_feature(trimws(feat_part))
t <- as.numeric(trimws(val_part))
if (any(is.na(t))) {
stop("Could not parse numeric target values from character input.", call. = FALSE)
}
return(.finalize_targets(f, t))
}
stop(
"Unsupported character targets format. Use 'feature=target' pairs or a single numeric string.",
call. = FALSE
)
}
stop("Unsupported targets format.", call. = FALSE)
}
# Configurations are single-assignment; defaults computed by readers do not
# populate these fields. Check before cloning or touching cached models.
.pa_assert_unconfigured <- function(x, fields, label, constructor) {
stopifnot(inherits(x, "Problem"))
if (any(vapply(fields, function(field) !is.null(x$data[[field]]), logical(1)))) {
stop(label, " already defined. ", constructor, " can only be called once per problem. ",
"Rebuild from the problem before this definition to change it.", call. = FALSE)
}
invisible(TRUE)
}
.pa_target_actions <- function(x, actions) {
if (is.null(actions)) return(NA_character_)
.pa_subset_to_string(.pa_resolve_action_subset(x, actions)$id)
}
.pa_constraint_name <- function(x, family, proposed, explicit = FALSE) {
names_used <- x$data$constraints[[family]]$name %||% character()
if (!(proposed %in% names_used)) return(proposed)
if (explicit) {
stop("Constraint name '", proposed, "' already exists in ", family, ".", call. = FALSE)
}
index <- 2L
while (paste0(proposed, "_", index) %in% names_used) index <- index + 1L
paste0(proposed, "_", index)
}
.pa_store_targets <- function(x, targets_df) {
stopifnot(inherits(x, "Problem"))
stopifnot(inherits(targets_df, "data.frame"))
stopifnot(all(c("feature", "type", "target_value") %in% names(targets_df)))
# normalize minimal fields
targets_df$feature <- as.integer(targets_df$feature)
targets_df$type <- as.character(targets_df$type)
targets_df$target_value <- as.numeric(targets_df$target_value)
# ensure actions column exists
if (!("actions" %in% names(targets_df))) {
targets_df$actions <- NA_character_
}
targets_df$actions <- as.character(targets_df$actions)
key_new <- paste(targets_df$feature, targets_df$type, targets_df$actions, sep = "||")
if (anyDuplicated(key_new)) {
stop("Duplicated targets for the same feature and action scope.", call. = FALSE)
}
valid_types <- c("actions")
bad_type <- setdiff(unique(targets_df$type), valid_types)
if (length(bad_type) > 0) {
stop("Unknown target types: ", paste(bad_type, collapse = ", "), call. = FALSE)
}
# initialize if empty
if (is.null(x$data$targets) || !inherits(x$data$targets, "data.frame") || nrow(x$data$targets) == 0) {
x$data$targets <- targets_df
if (!is.null(x$data$model_ptr)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$model_dirty <- TRUE
}
return(x)
}
old <- x$data$targets
old$feature <- as.integer(old$feature)
old$type <- as.character(old$type)
old$target_value <- as.numeric(old$target_value)
# backward compatibility: migrate old subset column if present
if (!("actions" %in% names(old))) {
if ("subset" %in% names(old)) {
old$actions <- as.character(old$subset)
} else {
old$actions <- NA_character_
}
}
old$actions <- as.character(old$actions)
# Absolute and relative targets share the same feature/action identity.
key_old <- paste0(old$feature, "||", old$type, "||", old$actions)
key_new <- paste0(targets_df$feature, "||", targets_df$type, "||", targets_df$actions)
overlap <- intersect(key_old, key_new)
if (length(overlap) > 0) {
stop(
"A target already exists for the same feature and action scope. ",
"Rebuild from the problem before this target to change it. ",
"Example key: ", overlap[1],
call. = FALSE
)
}
x$data$targets <- rbind(old, targets_df)
if (!is.null(x$data$model_ptr)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$model_dirty <- TRUE
}
x
}
.pa_feature_totals <- function(x) {
df <- x$data$dist_features
if (is.null(df) || nrow(df) == 0) {
stop("Need x$data$dist_features to compute baseline totals.", call. = FALSE)
}
stopifnot(all(c("feature","amount") %in% names(df)))
f <- as.numeric(df$feature)
a <- as.numeric(df$amount)
a[!is.finite(a) | is.na(a)] <- 0
out <- tapply(a, f, sum, na.rm = TRUE)
out[is.na(out)] <- 0
out
}
.pa_feature_potential <- function(x, value_col = "benefit") {
de <- x$data$dist_effects_model %||% x$data$dist_effects
if (is.null(de) || nrow(de) == 0) {
stop("Need dist_effects to compute potential. Run add_effects()/add_benefits() first.", call. = FALSE)
}
stopifnot(all(c("feature", value_col) %in% names(de)))
f <- as.numeric(de$feature)
v <- as.numeric(de[[value_col]])
# potential is sum of positive contributions only
v_pos <- pmax(v, 0)
v_pos[!is.finite(v_pos) | is.na(v_pos)] <- 0
out <- tapply(v_pos, f, sum, na.rm = TRUE)
out[is.na(out)] <- 0
out
}
# -----------------------------------------------------------------------------
# Apply targets to the active C++ model (helper)
# -----------------------------------------------------------------------------
# This helper is meant to be called INSIDE problem() after:
# - base variables have been added
# - structural constraints have been added
# - objective has been set (optional)
#
# It will:
# - read x$data$targets (data.frame)
# - decide per-feature whether we have conservation-only, recovery-only, or mixed
# - call the corresponding Rcpp function(s)
# - store a lightweight "applied_targets" summary in x$data$model_args
#
# Assumptions (consistent with your design):
# - x$data$model_ptr exists and is an XPtr<OptimizationProblem>
# - target_value is already ABSOLUTE in x$data$targets
# - conservation-only uses z variables + dist_features amounts
# - recovery-only uses x variables + dist_benefit deltas (can be + or -)
# - mixed (option 1) uses total = (conservation baseline) + (action deltas),
# with target = Tc + Tr if both targets exist for a feature.
# -----------------------------------------------------------------------------
# helper: get model-ready benefit table from dist_effects
.get_dist_benefit_model_from_effects <- function(x, benefit_col = "benefit") {
de <- x$data$dist_effects_model %||% x$data$dist_effects
if (is.null(de) || !inherits(de, "data.frame") || nrow(de) == 0) {
return(NULL)
}
benefit_col <- as.character(benefit_col)[1]
if (is.na(benefit_col) || !nzchar(benefit_col)) {
stop("`benefit_col` must be a non-empty string.", call. = FALSE)
}
if (!(benefit_col %in% names(de))) {
stop("dist_effects is missing column '", benefit_col, "'.", call. = FALSE)
}
out <- de
if ("feature" %in% names(out)) out$feature <- as.integer(out$feature)
if ("internal_pu" %in% names(out)) out$internal_pu <- as.integer(out$internal_pu)
if ("internal_action" %in% names(out)) out$internal_action <- as.integer(out$internal_action)
if ("internal_feature" %in% names(out)) out$internal_feature <- as.integer(out$internal_feature)
out$benefit <- as.numeric(out[[benefit_col]])
if (anyNA(out$benefit) || any(!is.finite(out$benefit))) {
stop(
"Column '", benefit_col, "' in dist_effects contains NA or non-finite values.",
call. = FALSE
)
}
out
}
.get_dist_effects_model <- function(x, mode = c("benefit", "loss", "delta")) {
mode <- match.arg(mode)
de <- x$data$dist_effects_model %||% x$data$dist_effects
if (is.null(de) || !inherits(de, "data.frame") || nrow(de) == 0) {
return(NULL)
}
out <- de
if ("feature" %in% names(out)) out$feature <- as.integer(out$feature)
if ("internal_pu" %in% names(out)) out$internal_pu <- as.integer(out$internal_pu)
if ("internal_action" %in% names(out)) out$internal_action <- as.integer(out$internal_action)
if ("internal_feature" %in% names(out)) out$internal_feature <- as.integer(out$internal_feature)
if (mode == "benefit") {
if (!("benefit" %in% names(out))) {
stop("dist_effects is missing column 'benefit'.", call. = FALSE)
}
out$benefit <- as.numeric(out$benefit)
if (anyNA(out$benefit) || any(!is.finite(out$benefit))) {
stop("dist_effects$benefit contains NA or non-finite values.", call. = FALSE)
}
out$effect <- out$benefit
return(out)
}
if (mode == "loss") {
if (!("loss" %in% names(out))) {
stop("dist_effects is missing column 'loss'.", call. = FALSE)
}
out$loss <- as.numeric(out$loss)
if (anyNA(out$loss) || any(!is.finite(out$loss))) {
stop("dist_effects$loss contains NA or non-finite values.", call. = FALSE)
}
out$effect <- out$loss
return(out)
}
# mode == "delta"
if (!("benefit" %in% names(out)) && !("loss" %in% names(out))) {
stop(
"dist_effects must contain at least one of 'benefit' or 'loss' to compute delta.",
call. = FALSE
)
}
if (!("benefit" %in% names(out))) out$benefit <- 0
if (!("loss" %in% names(out))) out$loss <- 0
out$benefit <- as.numeric(out$benefit)
out$loss <- as.numeric(out$loss)
if (anyNA(out$benefit) || any(!is.finite(out$benefit))) {
stop("dist_effects$benefit contains NA or non-finite values.", call. = FALSE)
}
if (anyNA(out$loss) || any(!is.finite(out$loss))) {
stop("dist_effects$loss contains NA or non-finite values.", call. = FALSE)
}
out$effect <- out$benefit - out$loss
out
}
.pa_apply_targets_if_present <- function(x,
zero_tol = 1e-12) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$targets) || !inherits(x$data$targets, "data.frame") || nrow(x$data$targets) == 0) {
return(invisible(x))
}
if (is.null(x$data$model_ptr)) {
stop("No active model pointer found in x$data$model_ptr. Run add_constraint_targets_*() before applying targets.", call. = FALSE)
}
t <- x$data$targets
req <- c("feature", "type", "target_value")
miss <- setdiff(req, names(t))
if (length(miss) > 0) {
stop("x$data$targets is missing required columns: ", paste(miss, collapse = ", "), call. = FALSE)
}
# backward compatibility: migrate subset -> actions
if (!("actions" %in% names(t))) {
if ("subset" %in% names(t)) {
t$actions <- as.character(t$subset)
} else {
t$actions <- NA_character_
}
}
t$feature <- as.integer(t$feature)
t$type <- as.character(t$type)
t$actions <- as.character(t$actions)
t$target_value <- as.numeric(t$target_value)
bad_type <- setdiff(unique(t$type), c("actions"))
if (length(bad_type) > 0) {
stop("Unknown target types in x$data$targets: ", paste(bad_type, collapse = ", "), call. = FALSE)
}
# ------------------------------------------------------------------
# 1) exact duplicates by (feature, type, actions) are NOT allowed
# ------------------------------------------------------------------
key_exact <- paste0(
t$feature, "||",
t$type, "||",
ifelse(is.na(t$actions), "", t$actions)
)
dup_exact <- duplicated(key_exact) | duplicated(key_exact, fromLast = TRUE)
if (any(dup_exact)) {
bad <- t[dup_exact, c("feature", "type", "actions", "target_value"), drop = FALSE]
ex <- utils::head(
paste0(
"(feature=", bad$feature,
", type='", bad$type,
"', actions='", ifelse(is.na(bad$actions) | !nzchar(bad$actions), "ALL", bad$actions),
"', target_value=", bad$target_value, ")"
),
8
)
stop(
"Multiple targets were defined for the same (feature, type, actions) combination.\n",
"This is ambiguous and is not allowed.\n",
"Examples: ", paste(ex, collapse = ", "),
if (nrow(bad) > 8) paste0(" ... (", nrow(bad), " rows)") else "",
call. = FALSE
)
}
# ------------------------------------------------------------------
# 2) same (feature, actions) with different type: allowed, but warn
# ------------------------------------------------------------------
key_feature_actions <- paste0(
t$feature, "||",
ifelse(is.na(t$actions), "", t$actions)
)
split_fa <- split(t$type, key_feature_actions, drop = TRUE)
multi_type_keys <- names(split_fa)[vapply(split_fa, function(z) length(unique(z)) > 1, logical(1))]
if (length(multi_type_keys) > 0) {
ex_keys <- utils::head(multi_type_keys, 8)
warning(
"Multiple targets were defined for the same (feature, actions) combination with different target types.\n",
"They will be applied as separate constraints, and the strongest one may dominate in practice.\n",
"Examples: ", paste(ex_keys, collapse = ", "),
if (length(multi_type_keys) > 8) paste0(" ... (", length(multi_type_keys), " combinations)") else "",
call. = FALSE
)
}
# ------------------------------------------------------------------
# 3) drop near-zero targets
# ------------------------------------------------------------------
idx_zero <- is.finite(t$target_value) & abs(t$target_value) <= zero_tol
if (any(idx_zero)) {
z <- t[idx_zero, , drop = FALSE]
warning(
"Skipping ", nrow(z), " target(s) with target_value ~ 0 (|rhs| <= ", format(zero_tol), "). ",
"They are redundant and can obscure infeasibility diagnostics.",
call. = FALSE
)
t <- t[!idx_zero, , drop = FALSE]
}
if (nrow(t) == 0) {
x$data$model_args$targets_applied <- TRUE
x$data$model_args$targets_counts <- list(actions = 0L)
return(invisible(x))
}
op <- x$data$model_ptr
.mk_targets_df <- function(features, values, colname) {
df <- data.frame(internal_id = as.integer(features), stringsAsFactors = FALSE)
df[[colname]] <- as.numeric(values)
df
}
.check_feature_present_in_df <- function(features, df, feature_col, what) {
features <- as.integer(features)
if (length(features) == 0) return(invisible(TRUE))
present <- unique(as.integer(df[[feature_col]]))
miss <- features[!features %in% present]
if (length(miss) > 0) {
ex <- paste(utils::head(sort(unique(miss)), 8), collapse = ", ")
stop(
"Infeasible targets detected: some features in ", what, " targets have no contributions in the model tables.\n",
"Missing feature ids: ", ex,
if (length(unique(miss)) > 8) paste0(" ... (", length(unique(miss)), " total)") else "",
call. = FALSE
)
}
invisible(TRUE)
}
.filter_effects_by_actions <- function(de, actions_string) {
if (is.na(actions_string) || !nzchar(actions_string)) {
return(de)
}
actions_vals <- strsplit(actions_string, "\\|")[[1]]
actions_vals <- unique(actions_vals[nzchar(actions_vals)])
matched <- .pa_resolve_action_subset(x, actions_vals)
keep_internal <- as.integer(matched$internal_id)
de[de$internal_action %in% keep_internal, , drop = FALSE]
}
if (.pa_uses_aggregate_effects(x)) {
return(invisible(.pa_apply_aggregate_targets(x, t)))
}
dbm <- .get_dist_benefit_model_from_effects(x, benefit_col = "amount_after")
if (is.null(dbm) || nrow(dbm) == 0) {
stop(
"Targets present but no action feature contributions are available in dist_effects. ",
"Run add_effects() first and make sure dist_effects contains 'amount_after'.",
call. = FALSE
)
}
if (!("feature" %in% names(dbm))) {
stop("dist_benefit_data must contain a 'feature' column for validation.", call. = FALSE)
}
if (!exists("rcpp_add_target_recovery", mode = "function")) {
stop("Missing rcpp_add_target_recovery() in the package.", call. = FALSE)
}
# ------------------------------------------------------------------
# 4) Map external feature ids in targets to internal feature ids
# ------------------------------------------------------------------
feature_map <- x$data$features[, c("id", "internal_id"), drop = FALSE]
feature_map$id <- as.integer(feature_map$id)
feature_map$internal_id <- as.integer(feature_map$internal_id)
t$internal_feature <- feature_map$internal_id[
match(as.integer(t$feature), feature_map$id)
]
if (anyNA(t$internal_feature)) {
missing_features <- unique(t$feature[is.na(t$internal_feature)])
stop(
"Some target features could not be mapped to internal feature ids: ",
paste(missing_features, collapse = ", "),
".",
call. = FALSE
)
}
# ------------------------------------------------------------------
# 5) Apply each row as a separate constraint
# ------------------------------------------------------------------
n_applied <- 0L
for (ii in seq_len(nrow(t))) {
tt <- t[ii, , drop = FALSE]
actions_string <- tt$actions[1]
dbm_sub <- .filter_effects_by_actions(dbm, actions_string)
if (nrow(dbm_sub) == 0) {
actions_lab <- if (is.na(actions_string) || !nzchar(actions_string)) {
"ALL actions"
} else {
actions_string
}
stop(
"Target for feature ", tt$feature[1],
" and actions subset '", actions_lab,
"' cannot be applied because no matching effect rows remain after filtering.",
call. = FALSE
)
}
.check_feature_present_in_df(
tt$internal_feature,
dbm_sub,
"internal_feature",
what = "actions"
)
rcpp_add_target_recovery(
op,
features_data = .mk_targets_df(
tt$internal_feature,
tt$target_value,
"target_actions"
),
dist_actions_data = x$data$dist_actions_model,
dist_benefit_data = dbm_sub,
target_col = "target_actions"
)
n_applied <- n_applied + 1L
}
x$data$model_args$targets_applied <- TRUE
x$data$model_args$targets_counts <- list(actions = n_applied)
invisible(x)
}
# -------------------------------------------------------------------------
# Internal helpers MATHEMATICAL MODEL
# -------------------------------------------------------------------------
.pa_refresh_model_snapshot <- function(x, drop_triplets = TRUE) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_ptr)) return(x)
if (!requireNamespace("Matrix", quietly = TRUE)) {
stop("Package 'Matrix' is required to build sparse constraint matrix.", call. = FALSE)
}
model_list <- rcpp_optimization_problem_as_list(x$data$model_ptr)
# Build sparse A defensively (A_i/A_j are 0-based in C++ -> +1 in R)
if (all(c("A_i", "A_j", "A_x") %in% names(model_list)) &&
length(model_list$A_i) == length(model_list$A_j) &&
length(model_list$A_i) == length(model_list$A_x)) {
model_list$A <- Matrix::sparseMatrix(
i = as.integer(model_list$A_i) + 1L,
j = as.integer(model_list$A_j) + 1L,
x = as.numeric(model_list$A_x),
dims = c(length(model_list$rhs), length(model_list$obj))
)
if (isTRUE(drop_triplets)) {
model_list$A_i <- NULL
model_list$A_j <- NULL
model_list$A_x <- NULL
}
} else {
# fallback: empty sparse matrix if missing triplets
n_con <- if (!is.null(model_list$rhs)) length(model_list$rhs) else 0L
n_var <- if (!is.null(model_list$obj)) length(model_list$obj) else 0L
model_list$A <- Matrix::sparseMatrix(
i = integer(0), j = integer(0), x = numeric(0),
dims = c(n_con, n_var)
)
}
# Keep args attached if you use them downstream (optional but handy)
model_list$args <- x$data$model_args %||% list()
x$data$model_list <- model_list
# Optional: store dims for fast printing
x$data$model_args <- x$data$model_args %||% list()
x$data$model_args$n_constraints <- if (!is.null(model_list$rhs)) length(model_list$rhs) else NA_integer_
x$data$model_args$n_variables <- if (!is.null(model_list$obj)) length(model_list$obj) else NA_integer_
x$data$model_args$nnz <- Matrix::nnzero(model_list$A)
x
}
# .pa_apply_action_max_per_pu_if_present <- function(x) {
# stopifnot(inherits(x, "Problem"))
#
# spec <- x$data$constraints$action_max_per_pu %||% NULL
# if (is.null(spec)) return(invisible(x))
#
# if (is.null(x$data$model_ptr)) {
# stop("No active model pointer found in x$data$model_ptr.", call. = FALSE)
# }
#
# if (!exists("rcpp_add_action_max_per_pu", mode = "function")) {
# stop("Missing rcpp_add_action_max_per_pu() in the package.", call. = FALSE)
# }
#
# da <- x$data$dist_actions_model
# if (is.null(da) || !inherits(da, "data.frame") || nrow(da) == 0) {
# stop("action_max_per_pu requires non-empty x$data$dist_actions_model.", call. = FALSE)
# }
#
# # defensive: required columns
# need <- c("internal_pu", "internal_action", "internal_row")
# miss <- setdiff(need, names(da))
# if (length(miss) > 0) {
# stop("dist_actions_model must contain columns: ", paste(miss, collapse = ", "), call. = FALSE)
# }
#
# maxv <- as.integer(spec$max %||% 1L)
# if (!is.finite(maxv) || is.na(maxv) || maxv < 0L) stop("Invalid max in action_max_per_pu.", call. = FALSE)
#
# # Convert external ids -> internal ids
# pu_ext <- spec$pu %||% x$data$pu$id
# pu_ext <- as.integer(pu_ext)
# pu_map <- x$data$pu[, c("id","internal_id")]
# pu_int <- pu_map$internal_id[match(pu_ext, pu_map$id)]
# pu_int <- pu_int[!is.na(pu_int)]
# if (length(pu_int) == 0) stop("action_max_per_pu: no valid PUs after mapping to internal ids.", call. = FALSE)
#
# act_ext <- spec$actions %||% x$data$actions$id
# act_ext <- as.character(act_ext)
# act_map <- x$data$actions[, c("id","internal_id")]
# act_int <- act_map$internal_id[match(act_ext, act_map$id)]
# act_int <- act_int[!is.na(act_int)]
# if (length(act_int) == 0) stop("action_max_per_pu: no valid actions after mapping to internal ids.", call. = FALSE)
#
# # call C++
# res <- rcpp_add_action_max_per_pu(
# x = x$data$model_ptr,
# dist_actions_data = da,
# max_per_pu = maxv,
# internal_pu_ids = as.integer(pu_int),
# internal_action_ids = as.integer(act_int)
# )
#
# # optional registry
# x$data$model_registry <- x$data$model_registry %||% list(cons = list(), vars = list(), obj_templates = list(), objective = list())
# x$data$model_registry$cons$action_max_per_pu <- res
#
# invisible(x)
# }
.pa_apply_area_constraints_if_present <- function(x) {
stopifnot(inherits(x, "Problem"))
.area_unit_convert_from_m2 <- function(area_m2, unit) {
unit <- match.arg(unit, c("m2", "ha", "km2"))
switch(
unit,
m2 = area_m2,
ha = area_m2 / 1e4,
km2 = area_m2 / 1e6
)
}
.is_missing_actions <- function(actions_txt) {
length(actions_txt) == 0L ||
is.na(actions_txt) ||
!nzchar(trimws(actions_txt)) ||
identical(trimws(actions_txt), "NA")
}
cons <- x$data$constraints %||% list()
if (length(cons) == 0L) return(x)
specs <- cons$area %||% NULL
if (is.null(specs)) return(x)
if (is.null(x$data$model_ptr)) {
stop("Model pointer is missing while applying area constraints.", call. = FALSE)
}
x <- .pa_refresh_model_snapshot(x)
ml <- x$data$model_list
if (is.null(ml)) {
stop("Model snapshot is missing while applying area constraints.", call. = FALSE)
}
n_pu <- as.integer(ml$n_pu %||% 0L)
if (n_pu <= 0L) {
stop("Model has n_pu=0; cannot apply area constraints.", call. = FALSE)
}
if (!is.data.frame(specs)) {
stop(
"Stored area constraints must be a data.frame.",
call. = FALSE
)
}
required_cols <- c(
"type", "sense", "value", "tolerance",
"unit", "area_col", "actions", "name"
)
miss <- setdiff(required_cols, names(specs))
if (length(miss) > 0) {
stop(
"Stored area constraints are malformed. Missing columns: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
w0 <- as.integer(ml$w_offset %||% 0L)
x0 <- as.integer(ml$x_offset %||% 0L)
j0_w <- w0 + (0:(n_pu - 1L))
da <- x$data$dist_actions_model %||% NULL
for (k in seq_len(nrow(specs))) {
spec <- specs[k, , drop = FALSE]
sense <- as.character(spec$sense)[1]
rhs <- as.numeric(spec$value)[1]
tol <- as.numeric(spec$tolerance)[1]
nm <- as.character(spec$name)[1]
area_col <- as.character(spec$area_col)[1]
area_unit <- as.character(spec$unit)[1]
actions_txt <- as.character(spec$actions)[1]
if (!sense %in% c("min", "max", "equal")) {
stop("Unknown area constraint sense: ", sense, call. = FALSE)
}
if (!area_unit %in% c("m2", "ha", "km2")) {
stop("Unknown area constraint unit: ", area_unit, call. = FALSE)
}
if (!is.finite(rhs) || is.na(rhs) || rhs < 0) {
stop("Invalid area constraint value in stored area constraints.", call. = FALSE)
}
if (!is.finite(tol) || is.na(tol) || tol < 0) {
stop("Invalid area constraint tolerance in stored area constraints.", call. = FALSE)
}
if (is.na(nm) || !nzchar(nm)) {
stop("Stored area constraint has invalid `name`.", call. = FALSE)
}
area_col_arg <- if (is.na(area_col) || !nzchar(area_col)) {
NULL
} else {
area_col
}
# ------------------------------------------------------------
# Case 1: actions = NULL
# Area of selected planning units: sum_i area_i * w_i
# ------------------------------------------------------------
if (.is_missing_actions(actions_txt)) {
a <- .pa_get_area_vec(
x,
area_col = area_col_arg,
area_unit = area_unit
)
if (length(a) != n_pu) {
stop(
"Area vector length (", length(a), ") != n_pu (", n_pu,
") while applying area constraint `", nm, "`.",
call. = FALSE
)
}
var_index <- j0_w
coeff <- as.numeric(a)
# ------------------------------------------------------------
# Case 2: actions != NULL
# Effective action area: sum_ia action_area_ia * x_ia
# ------------------------------------------------------------
} else {
if (is.null(da) || !is.data.frame(da) || nrow(da) == 0L) {
stop(
"Area constraints with `actions` require `x$data$dist_actions_model`.",
call. = FALSE
)
}
required_da_cols <- c(
"action",
"internal_row",
"internal_pu",
"action_area"
)
miss_da <- setdiff(required_da_cols, names(da))
if (length(miss_da) > 0L) {
stop(
"`dist_actions_model` must contain columns: ",
paste(miss_da, collapse = ", "),
".",
call. = FALSE
)
}
actions_chr <- strsplit(actions_txt, "\\|", fixed = FALSE)[[1]]
actions_chr <- trimws(actions_chr)
actions_chr <- actions_chr[
!is.na(actions_chr) &
nzchar(actions_chr) &
actions_chr != "NA"
]
act_subset <- .pa_resolve_action_subset(x, subset = actions_chr)
if (!is.data.frame(act_subset) || nrow(act_subset) == 0L) {
stop(
"Stored area constraint `", nm,
"` refers to an invalid or empty action subset.",
call. = FALSE
)
}
keep <- da$action %in% act_subset$id
if (!any(keep)) {
stop(
"Stored area constraint `", nm,
"` does not match any rows in `dist_actions_model`.",
call. = FALSE
)
}
da_sub <- da[keep, , drop = FALSE]
action_area_m2 <- as.numeric(da_sub$action_area)
missing_area <- is.na(action_area_m2)
if (any(missing_area)) {
pu_area_m2 <- tryCatch(
.pa_get_area_vec(
x,
area_col = area_col_arg,
area_unit = "m2"
),
error = function(e) NULL
)
if (!is.null(pu_area_m2)) {
names(pu_area_m2) <- as.character(x$data$pu$id)
action_area_m2[missing_area] <- as.numeric(
pu_area_m2[as.character(da_sub$pu[missing_area])]
)
}
}
if (
anyNA(action_area_m2) ||
any(!is.finite(action_area_m2))
) {
stop(
"Area constraint `", nm, "` uses `actions`, so it requires finite ",
"`action_area` values for all relevant feasible (pu, action) pairs. ",
"Provide `action_area` in add_actions(), use spatial include_pairs, ",
"or provide usable planning-unit areas through `area_col` or problem geometry.",
call. = FALSE
)
}
if (any(action_area_m2 < 0)) {
stop(
"`action_area` values used in area constraint `", nm,
"` must be non-negative.",
call. = FALSE
)
}
var_index <- x0 + (as.integer(da_sub$internal_row) - 1L)
coeff <- .area_unit_convert_from_m2(
action_area_m2,
area_unit
)
if (length(var_index) != length(coeff) || length(coeff) == 0L) {
stop(
"Failed to assemble coefficients for area constraint `", nm, "`.",
call. = FALSE
)
}
}
if (identical(sense, "min")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs,
name = nm,
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
} else if (identical(sense, "max")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs,
name = nm,
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
} else if (identical(sense, "equal")) {
if (tol == 0) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "==",
rhs = rhs,
name = nm,
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
} else {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs - tol,
name = paste0(nm, "_lower"),
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs + tol,
name = paste0(nm, "_upper"),
block_name = "area",
tag = if (.is_missing_actions(actions_txt)) "planning_units" else "actions"
)
}
}
}
x
}
.pa_cbc_complete_dimensions <- function(mat, row_lb, row_ub, col_lb, col_ub) {
# rcbc passes sparse triplets, rather than matrix dimensions, to CBC.
# Its native matrix therefore loses trailing empty rows/columns. One
# redundant bound row records both dimensions without deleting variables
# or changing their bounds, objective contributions, or returned indices.
nr <- nrow(mat)
nc <- ncol(mat)
if (nc > 0L && (nr == 0L ||
!any(mat[nr, , drop = FALSE] != 0) ||
!any(mat[, nc, drop = FALSE] != 0))) {
anchor <- Matrix::sparseMatrix(i = 1L, j = nc, x = 1, dims = c(1L, nc))
mat <- rbind(mat, anchor)
row_lb <- c(row_lb, col_lb[nc])
row_ub <- c(row_ub, col_ub[nc])
}
list(mat = mat, row_lb = row_lb, row_ub = row_ub)
}
.pa_positive_objective_scale <- function(obj) {
nonzero <- abs(obj[is.finite(obj) & obj != 0])
if (!length(nonzero)) return(1)
# A common positive factor preserves the scalar criterion exactly. Raise
# small rewards above solver tolerances without producing huge coefficients.
exponent <- max(0, min(6, ceiling(-log10(min(nonzero))),
floor(log10(1e8 / max(nonzero)))))
10^exponent
}
.pa_model_from_ptr <- function(op, args = list(), drop_triplets = TRUE) {
if (!requireNamespace("Matrix", quietly = TRUE)) {
stop("Package 'Matrix' is required to build sparse constraint matrix.", call. = FALSE)
}
model_list <- rcpp_optimization_problem_as_list(op)
# n_con / n_var siempre desde rhs/obj
n_con <- if (!is.null(model_list$rhs)) length(model_list$rhs) else 0L
n_var <- if (!is.null(model_list$obj)) length(model_list$obj) else 0L
# build sparse A defensively (A_i/A_j are 0-based -> +1)
if (all(c("A_i", "A_j", "A_x") %in% names(model_list)) &&
length(model_list$A_i) == length(model_list$A_j) &&
length(model_list$A_i) == length(model_list$A_x) &&
length(model_list$A_i) > 0L) {
model_list$A <- Matrix::sparseMatrix(
i = as.integer(model_list$A_i) + 1L,
j = as.integer(model_list$A_j) + 1L,
x = as.numeric(model_list$A_x),
dims = c(n_con, n_var) # <<< CRÍTICO: fija dimensiones reales
)
if (isTRUE(drop_triplets)) {
model_list$A_i <- NULL
model_list$A_j <- NULL
model_list$A_x <- NULL
}
} else {
model_list$A <- Matrix::sparseMatrix(
i = integer(0), j = integer(0), x = numeric(0),
dims = c(n_con, n_var)
)
}
# attach model args (needed for curve/segments and any other solver params)
model_list$args <- args %||% list()
# registry: ya viene desde C++ como data.frame en model_list$registry.
# No lo toques aquí; solo asegúrate de no borrarlo por error.
# (si quisieras, podrías validar que exista)
# if (is.null(model_list$registry)) model_list$registry <- data.frame()
model_list
}
# -------------------------------------------------------------------------
# Internal helpers CLASS
# -------------------------------------------------------------------------
.pa_cli_theme <- function() {
list(
.h = list("font-weight" = "bold", color = "#569746"),
.cls = list("font-weight" = "bold", color = "#4C78A8"),
.code = list(color = "#3A7D44"),
.muted = list(color = "grey60"),
.ok = list(color = "#569746", "font-weight" = "bold"),
.warn = list(color = "#C78A00", "font-weight" = "bold"),
.bad = list(color = "#C0392B", "font-weight" = "bold")
)
}
.pa_cli_box_chars <- function() {
use_unicode <- l10n_info()[["UTF-8"]]
if (isTRUE(use_unicode)) {
list(
j = "\u251C", # ├
l = "\u2514", # └
v = "\u2502", # │
b = "\u2500" # ─
)
} else {
list(
j = "+",
l = "\\",
v = "|",
b = "-"
)
}
}
.pa_safe_range <- function(x, digits = 5) {
x <- as.numeric(x)
x <- x[is.finite(x) & !is.na(x)]
if (length(x) == 0) return(NULL)
base::round(range(x), digits)
}
# .pa_repr_atomic <- function(x, label = NULL, max_items = 6) {
# x <- as.character(x)
# x <- x[!is.na(x) & nzchar(x)]
# if (length(x) == 0) {
# if (is.null(label)) return("{.muted (none)}")
# return(paste0("{.muted (0 ", label, ")}"))
# }
# if (length(x) <= max_items) {
# paste0(paste0('"', x, '"', collapse = ", "))
# } else {
# head <- x[seq_len(max_items)]
# paste0(
# paste0('"', head, '"', collapse = ", "),
# ", {.muted ... (", length(x), " total)}"
# )
# }
# }
.pa_get_cost_vec <- function(pu) {
if (is.null(pu) || nrow(pu) == 0) return(numeric(0))
if ("cost" %in% names(pu)) return(as.numeric(pu$cost))
if ("monitoring_cost" %in% names(pu)) return(as.numeric(pu$monitoring_cost))
numeric(0)
}
.pa_get_action_cost_vec <- function(self) {
# new field (preferred)
if (!is.null(self$data$dist_actions) &&
inherits(self$data$dist_actions, "data.frame") &&
nrow(self$data$dist_actions) > 0 &&
"cost" %in% names(self$data$dist_actions)) {
return(as.numeric(self$data$dist_actions$cost))
}
numeric(0)
}
.pa_nrow0 <- function(x) {
if (is.null(x)) return(0L)
if (!inherits(x, "data.frame")) return(0L)
nrow(x)
}
.pa_has_model <- function(self) {
!is.null(self$data$model_list) && is.list(self$data$model_list)
}
.pa_model_dims <- function(self) {
# Returns list(n_con, n_var, nnz) safely
ml <- self$data$model_list
# If model_list doesn't exist yet, return zeros
if (is.null(ml) || !is.list(ml)) {
return(list(n_con = 0L, n_var = 0L, nnz = 0L))
}
# Best effort: support both A (dgCMatrix) and triplet (A_i/A_j/A_x)
n_con <- 0L
n_var <- 0L
nnz <- 0L
if (!is.null(ml$A) && inherits(ml$A, "Matrix")) {
n_con <- nrow(ml$A)
n_var <- ncol(ml$A)
nnz <- length(ml$A@x)
return(list(n_con = as.integer(n_con), n_var = as.integer(n_var), nnz = as.integer(nnz)))
}
if (!is.null(ml$A_i) && !is.null(ml$A_j)) {
# We may not know nrow/ncol if not stored; infer n_con/n_var if present
nnz <- length(ml$A_i)
if (!is.null(ml$rhs)) n_con <- length(ml$rhs)
if (!is.null(ml$obj)) n_var <- length(ml$obj)
return(list(n_con = as.integer(n_con), n_var = as.integer(n_var), nnz = as.integer(nnz)))
}
# Fallback from rhs/obj if present
if (!is.null(ml$rhs)) n_con <- length(ml$rhs)
if (!is.null(ml$obj)) n_var <- length(ml$obj)
list(n_con = as.integer(n_con), n_var = as.integer(n_var), nnz = as.integer(nnz))
}
# .pa_model_blocks <- function(self) {
# # Returns list(n_w, n_x, n_z) if index mapping exists; otherwise NULL.
# # This expects you to store something like idx from rcpp_add_base_variables()
# # in self$data$model_index. Your idx currently returns w_index/x_index and
# # could also return z_index (recommended).
# idx <- self$data$model_index
# if (is.null(idx) || !is.list(idx)) return(NULL)
#
# n_w <- if (!is.null(idx$w_index)) length(idx$w_index) else NA_integer_
# n_x <- if (!is.null(idx$x_index)) length(idx$x_index) else NA_integer_
# n_z <- if (!is.null(idx$z_index)) length(idx$z_index) else NA_integer_
#
# # if none exist, don't print a misleading line
# if (is.na(n_w) && is.na(n_x) && is.na(n_z)) return(NULL)
#
# list(
# n_w = ifelse(is.na(n_w), 0L, as.integer(n_w)),
# n_x = ifelse(is.na(n_x), 0L, as.integer(n_x)),
# n_z = ifelse(is.na(n_z), 0L, as.integer(n_z))
# )
# }
# .pa_model_args <- function(self) {
# # Return a standardized args list if present; otherwise NULL
# a <- self$data$model_args
# if (is.null(a) || !is.list(a)) return(NULL)
#
# # Standardize expected fields (do not error if missing)
# out <- list(
# model_type = if (!is.null(a$model_type)) a$model_type else NA_character_,
# modelsense = if (!is.null(a$modelsense)) a$modelsense else NA_character_,
# objective_id = if (!is.null(a$objective_id)) a$objective_id else NA_character_,
# budget = if (!is.null(a$budget)) a$budget else NA_real_,
# blm = if (!is.null(a$blm)) a$blm else NA_real_,
# benefit_exponent = if (!is.null(a$benefit_exponent)) a$benefit_exponent else NA_integer_,
# curve_segments = if (!is.null(a$curve_segments)) a$curve_segments else NA_integer_
# )
#
# out
# }
# -------------------------------------------------------------------------
# Internal helpers DATA
# -------------------------------------------------------------------------
`%||%` <- function(a, b) if (is.null(a)) b else a
# internal helper: detect tabular vs spatial vs invalid mixes
# .pa_detect_input_mode <- function(pu, features, dist_features) {
#
# # ---- local helpers (NO imports; only type checks)
# .is_df <- function(x) inherits(x, "data.frame")
#
# .is_spatraster <- function(x) inherits(x, "SpatRaster")
# .is_spatvector <- function(x) inherits(x, "SpatVector")
# .is_sf <- function(x) inherits(x, "sf")
#
# .is_raster_path <- function(x) {
# is.character(x) && length(x) == 1L &&
# grepl("\\.(tif|tiff|grd|asc|nc)$", tolower(x))
# }
#
# .is_vector_path <- function(x) {
# is.character(x) && length(x) == 1L &&
# grepl("\\.(shp|gpkg|geojson|json|fgb)$", tolower(x))
# }
#
# .is_spatial_pu <- function(x) .is_spatraster(x) || .is_spatvector(x) || .is_sf(x) || .is_raster_path(x) || .is_vector_path(x)
# .is_spatial_features <- function(x) .is_spatraster(x) || .is_raster_path(x)
#
# dist_missing <- missing(dist_features) || is.null(dist_features)
#
# # ------------------------------------------------------------
# # Rule 1: If dist_features is provided as data.frame -> TABULAR
# # ------------------------------------------------------------
# if (!dist_missing) {
# if (!.is_df(dist_features)) {
# stop("`dist_features` must be a data.frame in tabular mode, or NULL/missing in spatial mode.", call. = FALSE)
# }
#
# # dist_features df => require pu + features df (avoid ambiguity)
# if (!.is_df(pu)) {
# stop("Tabular mode detected because `dist_features` is a data.frame, but `pu` is not a data.frame.", call. = FALSE)
# }
# if (!.is_df(features)) {
# stop("Tabular mode detected because `dist_features` is a data.frame, but `features` is not a data.frame.", call. = FALSE)
# }
#
# return(list(mode = "tabular"))
# }
#
# # ------------------------------------------------------------
# # Rule 2: dist_features missing/NULL -> could be SPATIAL or invalid
# # ------------------------------------------------------------
# # spatial mode requires at least one spatial-ish input
# if (.is_spatial_features(features) || .is_spatial_pu(pu)) {
# return(list(mode = "spatial"))
# }
#
# # dist_features missing + no spatial inputs -> invalid (user forgot dist_features)
# stop(
# "Could not determine input style. Provide tabular inputs (data.frames: `pu`, `features`, `dist_features`) ",
# "or spatial inputs (e.g., `pu` and/or `features` as rasters/vectors/paths) with `dist_features = NULL`.",
# call. = FALSE
# )
# }
# helpers
# .read_rast <- function(x) {
# if (is.null(x)) return(NULL)
# if (inherits(x, "SpatRaster")) return(x)
# if (is.character(x)) return(terra::rast(x))
# stop("Unsupported raster input.", call. = FALSE)
# }
# .read_vect <- function(x) {
# if (is.null(x)) return(NULL)
# if (inherits(x, "SpatVector")) return(x)
# if (inherits(x, "sf")) return(terra::vect(x))
# if (is.character(x)) return(terra::vect(x))
# stop("Unsupported vector input.", call. = FALSE)
# }
.is_raster_path <- function(x) {
is.character(x) && grepl("\\.(tif|tiff|grd|asc|nc)$", tolower(x))
}
# .fun_from_name <- function(name) {
# switch(
# name,
# mean = function(v, ...) mean(v, na.rm = TRUE),
# sum = function(v, ...) sum(v, na.rm = TRUE),
# stop("Unknown aggregation function: ", name, call. = FALSE)
# )
# }
.pa_has_coords <- function(x) {
is.list(x$data) && !is.null(x$data$pu_coords) &&
inherits(x$data$pu_coords, "data.frame") &&
all(c("id","x","y") %in% names(x$data$pu_coords)) &&
nrow(x$data$pu_coords) > 0
}
.pa_spatial_relations_summary <- function(x) {
rels <- x$data$spatial_relations
if (is.null(rels) || !is.list(rels) || length(rels) == 0) return(NULL)
nm <- names(rels)
if (is.null(nm)) nm <- rep("", length(rels))
nm[nm == ""] <- paste0("rel_", seq_along(nm))
out <- lapply(seq_along(rels), function(i) {
r <- rels[[i]]
if (!inherits(r, "data.frame") || nrow(r) == 0) {
return(data.frame(name = nm[i], edges = 0L, w_min = NA_real_, w_max = NA_real_))
}
w <- suppressWarnings(as.numeric(r$weight))
rng <- .pa_safe_range(w)
data.frame(
name = nm[i],
edges = as.integer(nrow(r)),
w_min = if (is.null(rng)) NA_real_ else rng[[1]],
w_max = if (is.null(rng)) NA_real_ else rng[[2]]
)
})
do.call(rbind, out)
}
# -------------------------------------------------------------------------
# Internal helpers SOLVER
# -------------------------------------------------------------------------
.pa_get_solve_args <- function(x,
solver = NULL,
gap_limit = NULL,
time_limit = NULL,
solution_limit = NULL,
cores = NULL,
verbose = NULL,
name_output_file = NULL,
output_file = NULL,
solver_params = NULL) {
stopifnot(inherits(x, "Problem"))
defaults <- list(
solver = "auto",
gap_limit = 0.0,
time_limit = .Machine$integer.max,
solution_limit = FALSE,
cores = NULL,
verbose = FALSE,
name_output_file = NULL,
output_file = FALSE,
solver_params = list()
)
stored <- x$data$solve_args %||% list()
if (!is.list(stored)) stored <- list()
out <- utils::modifyList(defaults, stored)
# ---- explicit overrides (optional)
if (!is.null(gap_limit)) out$gap_limit <- gap_limit
if (!is.null(time_limit)) out$time_limit <- time_limit
if (!is.null(solution_limit)) out$solution_limit <- solution_limit
if (!is.null(cores)) out$cores <- cores
if (!is.null(verbose)) out$verbose <- verbose
if (!is.null(name_output_file)) out$name_output_file <- name_output_file
if (!is.null(output_file)) out$output_file <- output_file
# solver override (NULL = not specified)
if (!is.null(solver)) {
solver <- as.character(solver)[1]
if (!identical(solver, "")) out$solver <- solver
}
# solver_params override/merge
if (!is.null(solver_params)) {
if (!is.list(solver_params)) stop("solver_params must be a list.", call. = FALSE)
out$solver_params <- utils::modifyList(out$solver_params %||% list(), solver_params)
}
# ---- normalize
out$solver <- as.character(out$solver)[1]
if (!out$solver %in% c("auto", "gurobi", "cplex", "cbc", "symphony")) {
stop("Unknown solver in x$data$solve_args$solver: ", out$solver,
". Use one of: auto, gurobi, cplex, cbc, symphony.", call. = FALSE)
}
out$gap_limit <- as.numeric(out$gap_limit)
if (!is.finite(out$gap_limit) || out$gap_limit < 0 || out$gap_limit > 1) {
stop("gap_limit must be a finite number in [0, 1].", call. = FALSE)
}
out$time_limit <- round(as.numeric(out$time_limit), 3)
if (!is.finite(out$time_limit) || out$time_limit < 0) {
stop("time_limit must be a finite number >= 0.", call. = FALSE)
}
if (!is.null(out$cores)) {
out$cores <- as.integer(out$cores)
if (length(out$cores) != 1L || !is.finite(out$cores) || out$cores < 1) {
stop("cores must be an integer >= 1.", call. = FALSE)
}
# cap cores defensively (avoid hard error inside solve)
max_cores <- parallel::detectCores(TRUE)
if (length(max_cores) == 1L && is.finite(max_cores) && out$cores > max_cores) {
out$cores <- as.integer(max_cores)
}
}
out$solution_limit <- isTRUE(out$solution_limit)
out$verbose <- isTRUE(out$verbose)
out$output_file <- isTRUE(out$output_file)
if (!is.null(out$name_output_file)) {
out$name_output_file <- as.character(out$name_output_file)[1]
if (is.na(out$name_output_file) || !nzchar(out$name_output_file)) {
out$name_output_file <- NULL
}
}
if (is.null(out$solver_params) || !is.list(out$solver_params)) out$solver_params <- list()
out
}
# Report and neutralize common settings that are unavailable through a
# particular R solver interface. This also protects objects created with older
# multiscape versions, before capability checks were performed by set_solver().
.pa_apply_solver_capabilities <- function(solver,
cores,
solution_limit,
output_file,
name_output_file,
solver_params,
warn = TRUE) {
unsupported <- character(0)
solver_params <- solver_params %||% list()
if (identical(solver, "cplex")) {
if (!is.null(cores)) unsupported <- c(unsupported, "cores")
if (isTRUE(solution_limit)) unsupported <- c(unsupported, "solution_limit")
if (isTRUE(output_file) ||
(!is.null(name_output_file) && !identical(output_file, FALSE))) {
unsupported <- c(unsupported, "write_log/log_file")
}
rcplex_parameters <- c(
"trace", "method", "preind", "aggind", "itlim", "epagap", "epgap",
"tilim", "disjcuts", "mipemphasis", "cliques", "nodesel", "probe",
"varsel", "flowcovers", "solnpoolagap", "solnpoolgap",
"solnpoolintensity", "maxcalls", "round"
)
unknown <- setdiff(names(solver_params), rcplex_parameters)
if (length(unknown) > 0L) {
unsupported <- c(
unsupported,
paste0("solver_params$", unknown)
)
solver_params[unknown] <- NULL
}
cores <- NULL
solution_limit <- FALSE
output_file <- FALSE
name_output_file <- NULL
}
if (identical(solver, "symphony")) {
if (!is.null(cores)) unsupported <- c(unsupported, "cores")
if (isTRUE(output_file) ||
(!is.null(name_output_file) && !identical(output_file, FALSE))) {
unsupported <- c(unsupported, "write_log/log_file")
}
if (length(solver_params) > 0L) {
unsupported <- c(unsupported, "solver_params")
}
cores <- NULL
output_file <- FALSE
name_output_file <- NULL
solver_params <- list()
}
if (identical(solver, "cbc")) {
if (!is.null(cores)) {
unsupported <- c(unsupported, "cores (thread control is not available through rcbc)")
cores <- NULL
}
if (isTRUE(output_file) ||
(!is.null(name_output_file) && !identical(output_file, FALSE))) {
unsupported <- c(unsupported, "write_log/log_file")
output_file <- FALSE
name_output_file <- NULL
}
}
unsupported <- unique(unsupported)
if (isTRUE(warn) && length(unsupported) > 0L) {
warning(
paste0(
"Parameter(s) not available for solver '", solver,
"' through its current R interface: ",
paste(unsupported, collapse = ", "),
". The unsupported setting(s) will be ignored."
),
call. = FALSE,
immediate. = TRUE
)
}
list(
cores = cores,
solution_limit = isTRUE(solution_limit),
output_file = isTRUE(output_file),
name_output_file = name_output_file,
solver_params = solver_params %||% list()
)
}
# -------------------------------------------------------------------------
# Internal helpers SOLUTIONS
# -------------------------------------------------------------------------
.pa_extract_solution_tables <- function(x, sol, threshold = 0.5) {
stopifnot(inherits(x, "Problem"))
stopifnot(is.numeric(sol))
# --- get model list (snapshot) or from ptr
ml <- x$data$model_list %||% NULL
if (is.null(ml)) {
stopifnot(!is.null(x$data$model_ptr))
ml <- rcpp_optimization_problem_as_list(x$data$model_ptr)
}
# --- fallbacks if model metadata missing
pu_df <- x$data$pu
da_df <- x$data$dist_actions_model %||% x$data$dist_actions
df_df <- x$data$dist_features
n_pu <- as.integer(ml$n_pu %||% nrow(pu_df) %||% 0L)
n_x <- as.integer(ml$n_x %||% (if (inherits(da_df, "data.frame")) nrow(da_df) else 0L))
n_z <- as.integer(ml$n_z %||% (if (inherits(df_df, "data.frame")) nrow(df_df) else 0L))
w_off <- as.integer(ml$w_offset %||% 0L)
x_off <- as.integer(ml$x_offset %||% 0L)
z_off <- as.integer(ml$z_offset %||% 0L)
slice_safe <- function(v, start1, end1) {
if (length(v) == 0) return(numeric(0))
if (is.na(start1) || is.na(end1) || start1 > end1) return(numeric(0))
end1 <- min(end1, length(v))
start1 <- min(max(1L, start1), end1)
v[start1:end1]
}
# --- slices
w <- if (n_pu > 0L) slice_safe(sol, w_off + 1L, w_off + n_pu) else numeric(0)
xv <- if (n_x > 0L) slice_safe(sol, x_off + 1L, x_off + n_x ) else numeric(0)
zv <- if (n_z > 0L) slice_safe(sol, z_off + 1L, z_off + n_z ) else numeric(0)
# -------------------------
# 1) PU selection table
# -------------------------
pu_out <- pu_df
if (!inherits(pu_out, "data.frame") || nrow(pu_out) == 0) {
pu_out <- data.frame()
} else {
if (length(w) != nrow(pu_out)) {
warning(
"Mismatch: nrow(pu) = ", nrow(pu_out),
" but length(w slice) = ", length(w),
". Setting pu$selected = NA.",
call. = FALSE
)
pu_out$selected <- rep(NA_integer_, nrow(pu_out))
} else {
pu_out$selected <- as.integer(w > threshold)
}
}
# -------------------------
# 2) Actions selection table
# -------------------------
da_out <- da_df
if (!inherits(da_out, "data.frame") || nrow(da_out) == 0) {
da_out <- data.frame()
} else {
if (length(xv) != nrow(da_out)) {
warning(
"Mismatch: nrow(dist_actions_model) = ", nrow(da_out),
" but length(x slice) = ", length(xv),
". Setting actions$selected = NA.",
call. = FALSE
)
da_out$selected <- rep(NA_integer_, nrow(da_out))
} else {
da_out$selected <- as.integer(xv > threshold)
}
if (all(c("internal_pu", "internal_action") %in% names(da_out))) {
key_da <- paste0(da_out$internal_pu, ":", da_out$internal_action)
if (anyDuplicated(key_da)) {
stop(
"dist_actions_model has duplicated (internal_pu, internal_action) pairs. ",
"This breaks mapping of effects->x. Fix upstream (ensure unique feasible pairs).",
call. = FALSE
)
}
}
}
# -------------------------
# 3) Features summary
# -------------------------
feats <- x$data$features
de <- x$data$dist_effects_model %||% x$data$dist_effects
# Baseline total in the full landscape.
# This is contextual information, not achieved amount.
baseline_by_feat <- data.frame(
internal_feature = integer(0),
baseline_total = numeric(0)
)
if (!is.null(df_df) &&
inherits(df_df, "data.frame") &&
nrow(df_df) > 0 &&
all(c("internal_feature", "amount") %in% names(df_df))) {
df2 <- df_df
df2$amount <- as.numeric(df2$amount)
baseline_by_feat <- stats::aggregate(
baseline_total ~ internal_feature,
data = data.frame(
internal_feature = as.integer(df2$internal_feature),
baseline_total = as.numeric(df2$amount)
),
FUN = sum
)
}
# Map action-solution values to effect rows.
de_with_x <- NULL
if (!is.null(de) &&
inherits(de, "data.frame") &&
nrow(de) > 0 &&
length(xv) > 0 &&
all(c("internal_pu", "internal_action", "internal_feature") %in% names(de)) &&
inherits(da_out, "data.frame") &&
nrow(da_out) > 0 &&
all(c("internal_pu", "internal_action") %in% names(da_out))) {
key_da <- paste0(da_out$internal_pu, ":", da_out$internal_action)
map <- stats::setNames(seq_len(nrow(da_out)), key_da)
key_de <- paste0(de$internal_pu, ":", de$internal_action)
xrow <- unname(map[key_de])
ok <- !is.na(xrow)
if (!all(ok)) {
warning(
sum(!ok),
" rows in dist_effects have no matching (pu, action) in dist_actions_model and were ignored.",
call. = FALSE
)
de <- de[ok, , drop = FALSE]
xrow <- xrow[ok]
}
ok2 <- xrow >= 1L & xrow <= length(xv)
if (!all(ok2)) {
warning(
sum(!ok2),
" mapped x rows fall outside the x slice (length(x) = ", length(xv), "); ignored.",
call. = FALSE
)
de <- de[ok2, , drop = FALSE]
xrow <- xrow[ok2]
}
de_with_x <- de
de_with_x$x_value <- as.numeric(xv[xrow])
if (!("benefit" %in% names(de_with_x))) de_with_x$benefit <- 0
if (!("loss" %in% names(de_with_x))) de_with_x$loss <- 0
if (!("amount_after" %in% names(de_with_x))) de_with_x$amount_after <- 0
de_with_x$benefit <- as.numeric(de_with_x$benefit)
de_with_x$loss <- as.numeric(de_with_x$loss)
de_with_x$amount_after <- as.numeric(de_with_x$amount_after)
de_with_x$benefit[is.na(de_with_x$benefit)] <- 0
de_with_x$loss[is.na(de_with_x$loss)] <- 0
de_with_x$amount_after[is.na(de_with_x$amount_after)] <- 0
# Selected effects.
de_with_x$selected_benefit <- de_with_x$benefit * de_with_x$x_value
de_with_x$selected_loss <- de_with_x$loss * de_with_x$x_value
de_with_x$selected_net <- de_with_x$selected_benefit - de_with_x$selected_loss
de_with_x$selected_amount_after <- de_with_x$amount_after * de_with_x$x_value
# Baseline amount in selected action rows.
# Since amount_after = baseline + net, then baseline = amount_after - net.
de_with_x$baseline_amount <- de_with_x$amount_after - (de_with_x$benefit - de_with_x$loss)
de_with_x$baseline_amount[is.na(de_with_x$baseline_amount)] <- 0
de_with_x$selected_baseline <- de_with_x$baseline_amount * de_with_x$x_value
}
if (.pa_uses_aggregate_effects(x)) de_with_x <- .pa_joint_selected_features(x, da_out)
# Aggregated selected quantities by feature.
selected_baseline_by_feat <- data.frame(
internal_feature = integer(0),
selected_baseline = numeric(0)
)
selected_amount_after_by_feat <- data.frame(
internal_feature = integer(0),
selected_amount_after = numeric(0)
)
selected_benefit_by_feat <- data.frame(
internal_feature = integer(0),
selected_benefit = numeric(0)
)
selected_loss_by_feat <- data.frame(
internal_feature = integer(0),
selected_loss = numeric(0)
)
selected_net_by_feat <- data.frame(
internal_feature = integer(0),
selected_net = numeric(0)
)
if (!is.null(de_with_x) && nrow(de_with_x) > 0) {
selected_baseline_by_feat <- stats::aggregate(
selected_baseline ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_baseline = as.numeric(de_with_x$selected_baseline)
),
FUN = sum
)
selected_amount_after_by_feat <- stats::aggregate(
selected_amount_after ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_amount_after = as.numeric(de_with_x$selected_amount_after)
),
FUN = sum
)
selected_benefit_by_feat <- stats::aggregate(
selected_benefit ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_benefit = as.numeric(de_with_x$selected_benefit)
),
FUN = sum
)
selected_loss_by_feat <- stats::aggregate(
selected_loss ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_loss = as.numeric(de_with_x$selected_loss)
),
FUN = sum
)
selected_net_by_feat <- stats::aggregate(
selected_net ~ internal_feature,
data = data.frame(
internal_feature = as.integer(de_with_x$internal_feature),
selected_net = as.numeric(de_with_x$selected_net)
),
FUN = sum
)
}
# Main feature table.
if (is.null(feats) || !inherits(feats, "data.frame") || nrow(feats) == 0) {
feat_tbl <- data.frame()
} else {
feat_tbl <- data.frame(
feature = as.integer(feats$internal_id),
feature_name = if ("name" %in% names(feats)) as.character(feats$name) else as.character(feats$id),
stringsAsFactors = FALSE
)
feat_tbl <- dplyr::left_join(
feat_tbl,
baseline_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_baseline_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_amount_after_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_benefit_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_loss_by_feat,
by = c("feature" = "internal_feature")
)
feat_tbl <- dplyr::left_join(
feat_tbl,
selected_net_by_feat,
by = c("feature" = "internal_feature")
)
fill_zero_cols <- c(
"baseline_total",
"selected_baseline",
"selected_amount_after",
"selected_benefit",
"selected_loss",
"selected_net"
)
for (cc in fill_zero_cols) {
if (!cc %in% names(feat_tbl)) {
feat_tbl[[cc]] <- 0
}
feat_tbl[[cc]][is.na(feat_tbl[[cc]])] <- 0
}
feat_tbl$selected_fraction_of_baseline <- ifelse(
feat_tbl$baseline_total > 0,
feat_tbl$selected_amount_after / feat_tbl$baseline_total,
NA_real_
)
# Optional backwards-compatible aliases.
# You can remove these later if you want a cleaner output.
feat_tbl$total_available <- feat_tbl$baseline_total
feat_tbl$benefit <- feat_tbl$selected_benefit
feat_tbl$loss <- feat_tbl$selected_loss
feat_tbl$net <- feat_tbl$selected_net
feat_tbl$amount_after <- feat_tbl$selected_amount_after
# Do NOT compute:
# feat_tbl$total <- feat_tbl$total_available + feat_tbl$net
#
# That would imply that unselected units remain part of the achieved output,
# which is not the interpretation used here.
}
# -------------------------
# 4) Targets summary
# -------------------------
tgt <- x$data$targets
tgt_out <- NULL
if (inherits(tgt, "data.frame") &&
nrow(tgt) > 0 &&
all(c("feature", "type", "target_value") %in% names(tgt)) &&
inherits(feat_tbl, "data.frame") &&
nrow(feat_tbl) > 0) {
tgt2 <- tgt
tgt2$feature <- as.integer(tgt2$feature)
tgt2$type <- as.character(tgt2$type)
tgt2$target_value <- as.numeric(tgt2$target_value)
# Backward compatibility: old code used subset; newer code uses actions.
if (!("actions" %in% names(tgt2))) {
if ("subset" %in% names(tgt2)) {
tgt2$actions <- as.character(tgt2$subset)
} else {
tgt2$actions <- NA_character_
}
}
tgt2$actions <- as.character(tgt2$actions)
tgt2$achieved <- NA_real_
.achieved_for_actions <- function(feature_ids, actions_string) {
if (is.null(de_with_x) || nrow(de_with_x) == 0) {
return(stats::setNames(rep(0, length(feature_ids)), feature_ids))
}
dd <- de_with_x
if (!is.na(actions_string) && nzchar(actions_string)) {
matched <- .pa_resolve_action_subset(x, strsplit(actions_string, "\\|")[[1]])
keep_actions <- as.integer(matched$internal_id)
if (.pa_uses_aggregate_effects(x)) {
dd <- .pa_joint_selected_features(x, da_out, keep_actions)
} else {
dd <- dd[dd$internal_action %in% keep_actions, , drop = FALSE]
}
}
if (nrow(dd) == 0) {
return(stats::setNames(rep(0, length(feature_ids)), feature_ids))
}
tmp <- data.frame(
feature = as.integer(x$data$features$id[match(dd$internal_feature, x$data$features$internal_id)]),
achieved = as.numeric(dd$selected_amount_after)
)
agg <- stats::aggregate(achieved ~ feature, data = tmp, FUN = sum)
out <- stats::setNames(rep(0, length(feature_ids)), feature_ids)
hit <- match(feature_ids, agg$feature)
ok <- !is.na(hit)
out[ok] <- agg$achieved[hit[ok]]
out
}
split_key <- ifelse(is.na(tgt2$actions) | !nzchar(tgt2$actions), "__ALL__", tgt2$actions)
idx_split <- split(seq_len(nrow(tgt2)), split_key)
for (nm in names(idx_split)) {
ii <- idx_split[[nm]]
actions_string <- tgt2$actions[ii][1]
feats_i <- tgt2$feature[ii]
achieved_i <- .achieved_for_actions(feats_i, actions_string)
tgt2$achieved[ii] <- as.numeric(achieved_i[as.character(feats_i)])
}
tgt2$gap <- tgt2$achieved - tgt2$target_value
tgt_out <- tgt2
}
list(
pu = pu_out,
actions = da_out,
features = feat_tbl,
targets = tgt_out
)
}
# -------------------------------------------------------------------------
# Internal helpers AREAS
# -------------------------------------------------------------------------
.pa_get_area_vec <- function(x,
area_col = NULL,
area_unit = c("m2", "ha", "km2")) {
stopifnot(inherits(x, "Problem"))
area_unit <- match.arg(area_unit)
pu <- x$data$pu
if (is.null(pu) || !inherits(pu, "data.frame")) {
stop("x$data$pu is missing or is not a data.frame.", call. = FALSE)
}
n_pu <- nrow(pu)
if (n_pu <= 0L) {
stop(
"x$data$pu has zero rows; cannot retrieve planning unit areas.",
call. = FALSE
)
}
area <- NULL
area_source <- NULL
area_col_used <- NULL
# ---------------------------------------------------------
# helper: retrieve an area column from pu_data_raw aligned to x$data$pu$id
# ---------------------------------------------------------
get_raw_area <- function(col) {
raw <- x$data$pu_data_raw
if (is.null(raw) || !inherits(raw, "data.frame")) {
return(NULL)
}
if (!(col %in% names(raw))) {
return(NULL)
}
if (!("id" %in% names(raw))) {
stop(
"x$data$pu_data_raw is missing an 'id' column.",
call. = FALSE
)
}
raw_id <- as.integer(raw$id)
pu_id <- as.integer(pu$id)
if (anyNA(raw_id) || anyNA(pu_id)) {
stop(
"Could not coerce x$data$pu$id or x$data$pu_data_raw$id to integer ",
"while retrieving planning unit areas.",
call. = FALSE
)
}
if (anyDuplicated(raw_id) != 0L) {
stop(
"x$data$pu_data_raw$id contains duplicated planning unit ids.",
call. = FALSE
)
}
m <- match(pu_id, raw_id)
if (anyNA(m)) {
stop(
"Could not match all x$data$pu$id values to x$data$pu_data_raw$id ",
"while retrieving planning unit areas.",
call. = FALSE
)
}
as.numeric(raw[[col]][m])
}
# ---------------------------------------------------------
# 1) explicit area_col
# ---------------------------------------------------------
if (!is.null(area_col)) {
area_col <- as.character(area_col)[1]
if (is.na(area_col) || !nzchar(area_col)) {
stop(
"area_col must be a non-empty string or NULL.",
call. = FALSE
)
}
# 1a) from x$data$pu
if (area_col %in% names(pu)) {
area <- as.numeric(pu[[area_col]])
area_source <- "pu"
area_col_used <- area_col
# 1b) from x$data$pu_sf
} else if (
!is.null(x$data$pu_sf) &&
inherits(x$data$pu_sf, "sf") &&
area_col %in% names(x$data$pu_sf)
) {
area <- as.numeric(x$data$pu_sf[[area_col]])
area_source <- "pu_sf"
area_col_used <- area_col
# 1c) from x$data$pu_data_raw
} else if (
!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame") &&
area_col %in% names(x$data$pu_data_raw)
) {
area <- get_raw_area(area_col)
area_source <- "pu_data_raw"
area_col_used <- area_col
} else {
stop(
"area_col '", area_col, "' was not found in x$data$pu",
if (!is.null(x$data$pu_sf) && inherits(x$data$pu_sf, "sf")) {
", x$data$pu_sf"
} else {
""
},
if (!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame")) {
", or x$data$pu_data_raw."
} else {
"."
},
" Provide a valid area column or spatial information.",
call. = FALSE
)
}
}
# ---------------------------------------------------------
# 2) automatic lookup if area_col is NULL
# ---------------------------------------------------------
cand <- c(
"area",
"Area",
"AREA",
"surf",
"surface",
"area_m2",
"area_ha",
"area_km2"
)
# 2a) automatic lookup in x$data$pu
if (is.null(area)) {
hit_pu <- cand[cand %in% names(pu)][1]
if (!is.na(hit_pu) && length(hit_pu) == 1L) {
area <- as.numeric(pu[[hit_pu]])
area_source <- "pu"
area_col_used <- hit_pu
}
}
# 2b) automatic lookup in x$data$pu_sf
if (
is.null(area) &&
!is.null(x$data$pu_sf) &&
inherits(x$data$pu_sf, "sf")
) {
hit_sf <- cand[cand %in% names(x$data$pu_sf)][1]
if (!is.na(hit_sf) && length(hit_sf) == 1L) {
area <- as.numeric(x$data$pu_sf[[hit_sf]])
area_source <- "pu_sf"
area_col_used <- hit_sf
}
}
# 2c) automatic lookup in x$data$pu_data_raw
if (
is.null(area) &&
!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame")
) {
hit_raw <- cand[cand %in% names(x$data$pu_data_raw)][1]
if (!is.na(hit_raw) && length(hit_raw) == 1L) {
area <- get_raw_area(hit_raw)
area_source <- "pu_data_raw"
area_col_used <- hit_raw
}
}
# ---------------------------------------------------------
# 3) derive from geometry if possible
# ---------------------------------------------------------
if (is.null(area)) {
if (!is.null(x$data$pu_sf) && inherits(x$data$pu_sf, "sf")) {
area <- as.numeric(sf::st_area(x$data$pu_sf))
area_source <- "geometry_sf"
area_col_used <- NA_character_
# future raster branch could go here
# else if (...) {
# area <- ...
# area_source <- "geometry_raster"
# }
} else {
stop(
"Could not retrieve planning unit area.\n",
"No usable area column was found in x$data$pu",
if (!is.null(x$data$pu_data_raw) &&
inherits(x$data$pu_data_raw, "data.frame")) {
" or x$data$pu_data_raw"
} else {
""
},
", and no spatial geometry is available to derive area internally.\n",
"Provide `area_col` explicitly or build the Problem object with spatial information.",
call. = FALSE
)
}
}
# ---------------------------------------------------------
# 4) validate length and values
# ---------------------------------------------------------
if (length(area) != n_pu) {
stop(
"Area vector length (", length(area), ") != n_pu (", n_pu, "). ",
"Area source: ", area_source,
if (!is.null(area_col_used) && !is.na(area_col_used)) {
paste0(" [column='", area_col_used, "']")
} else {
""
},
".",
call. = FALSE
)
}
if (anyNA(area) || any(!is.finite(area))) {
stop(
"Area vector contains NA or non-finite values.",
call. = FALSE
)
}
if (any(area < 0)) {
stop(
"Area vector contains negative values.",
call. = FALSE
)
}
# ---------------------------------------------------------
# 5) convert to requested output units
# assume raw geometry/st_area is m2
# if column name suggests ha/km2, convert accordingly
# ---------------------------------------------------------
area_m2 <- area
if (!is.null(area_col_used) && !is.na(area_col_used)) {
nm <- tolower(area_col_used)
if (grepl("km2", nm, fixed = TRUE)) {
area_m2 <- area * 1e6
} else if (grepl("ha", nm, fixed = TRUE)) {
area_m2 <- area * 1e4
} else {
# assume already in m2 for generic names like area/surf/surface
area_m2 <- area
}
}
out <- switch(
area_unit,
m2 = area_m2,
ha = area_m2 / 1e4,
km2 = area_m2 / 1e6
)
names(out) <- as.character(pu$id)
out
}
# helper: ensure model built and model_list snapshot available
.pa_ensure_model_snapshot <- function(x) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_ptr)) {
x <- .pa_build_model(x)
}
if (is.null(x$data$model_list) || isTRUE(x$data$meta$model_dirty)) {
x <- .pa_refresh_model_snapshot(x)
x$data$meta$model_dirty <- FALSE
}
x
}
# helper: add 1 linear constraint sum(coeff_j * x_j) (sense) rhs
# NOTE: replace this with YOUR real C++ bridge that appends rows/triplets/rhs/sense.
.pa_add_linear_constraint <- function(
x,
var_index_0based,
coeff,
sense = c(">=", "<=", "=="),
rhs,
name = NULL,
block_name = "linear_constraint",
tag = "",
drop_zeros = TRUE,
merge_duplicates = TRUE,
refresh_snapshot = FALSE
) {
sense <- match.arg(sense)
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_ptr)) {
stop("Model pointer missing. Build model first.", call. = FALSE)
}
# ---- validate inputs
if (!is.numeric(var_index_0based) || !is.numeric(coeff)) {
stop("var_index_0based and coeff must be numeric.", call. = FALSE)
}
if (length(var_index_0based) != length(coeff)) {
stop("Length mismatch: var_index_0based and coeff must have the same length.", call. = FALSE)
}
if (!is.numeric(rhs) || length(rhs) != 1L || !is.finite(rhs)) {
stop("rhs must be a single finite numeric value.", call. = FALSE)
}
j0 <- as.integer(var_index_0based)
a <- as.numeric(coeff)
# ---- drop NA / non-finite / zero
keep <- !(is.na(j0) | is.na(a) | !is.finite(a))
if (isTRUE(drop_zeros)) keep <- keep & (a != 0)
j0 <- j0[keep]
a <- a[keep]
if (length(j0) == 0L) {
stop("Linear constraint has no non-zero coefficients after filtering.", call. = FALSE)
}
# ---- optionally merge duplicates (important if you build vectors by rbind/cbind)
if (isTRUE(merge_duplicates) && length(j0) > 1L) {
o <- order(j0)
j0 <- j0[o]; a <- a[o]
# aggregate by j0
u <- unique(j0)
a2 <- numeric(length(u))
idx <- match(j0, u)
for (k in seq_along(a)) a2[idx[k]] <- a2[idx[k]] + a[k]
j0 <- u
a <- a2
if (isTRUE(drop_zeros)) {
keep2 <- a != 0
j0 <- j0[keep2]
a <- a[keep2]
}
if (length(j0) == 0L) {
stop("Linear constraint became empty after merging duplicates.", call. = FALSE)
}
}
name <- as.character(name %||% "")[1]
block_name <- as.character(block_name %||% "linear_constraint")[1]
tag <- as.character(tag %||% "")[1]
# ---- call C++
out <- rcpp_add_linear_constraint(
model_ptr = x$data$model_ptr,
j0 = j0,
x = a,
sense = sense,
rhs = as.numeric(rhs),
name = name,
block_name = block_name,
tag = tag
)
if (isTRUE(refresh_snapshot)) {
x <- .pa_refresh_model_snapshot(x)
}
# store last-added info (optional, but handy for debugging)
x$data$model_registry <- x$data$model_registry %||% list()
x$data$model_registry$last_linear_constraint <- out
x
}
# -------------------------------------------------------------------------
# Internal helpers spatial relations
# -------------------------------------------------------------------------
.pa_validate_relation <- function(rel, n_pu, allow_self = FALSE,
dup_agg = c("sum", "max", "min", "mean")) {
stopifnot(is.data.frame(rel))
dup_agg <- match.arg(dup_agg)
req <- c("internal_pu1", "internal_pu2", "weight")
miss <- setdiff(req, names(rel))
if (length(miss) > 0) stop("Relation is missing columns: ", paste(miss, collapse = ", "), call. = FALSE)
rel$internal_pu1 <- as.integer(rel$internal_pu1)
rel$internal_pu2 <- as.integer(rel$internal_pu2)
rel$weight <- as.numeric(rel$weight)
if (anyNA(rel$internal_pu1) || anyNA(rel$internal_pu2) || anyNA(rel$weight)) {
stop("Relation has NA in internal_pu1/internal_pu2/weight.", call. = FALSE)
}
if (any(rel$internal_pu1 < 1L | rel$internal_pu1 > n_pu)) stop("internal_pu1 out of range.", call. = FALSE)
if (any(rel$internal_pu2 < 1L | rel$internal_pu2 > n_pu)) stop("internal_pu2 out of range.", call. = FALSE)
if (!allow_self && any(rel$internal_pu1 == rel$internal_pu2)) stop("Self-edges are not allowed.", call. = FALSE)
if (any(!is.finite(rel$weight)) || any(rel$weight < 0)) stop("weight must be finite and >= 0.", call. = FALSE)
# undirected canonical ordering
a <- pmin(rel$internal_pu1, rel$internal_pu2)
b <- pmax(rel$internal_pu1, rel$internal_pu2)
rel$internal_pu1 <- a
rel$internal_pu2 <- b
# columns to keep
core <- c("internal_pu1", "internal_pu2", "weight")
extra_cols <- intersect(names(rel), c("pu1","pu2","distance","source"))
keep <- c(core, extra_cols)
# aggregate duplicates
key <- paste(rel$internal_pu1, rel$internal_pu2)
if (anyDuplicated(key) != 0) {
FUN <- switch(
dup_agg,
sum = sum,
max = max,
min = min,
mean = mean
)
# aggregate ONLY weight (core), then optionally restore extras deterministically
agg <- stats::aggregate(
weight ~ internal_pu1 + internal_pu2,
data = rel[, core, drop = FALSE],
FUN = FUN
)
# if extras exist, attach a deterministic representative per edge (first row)
if (length(extra_cols) > 0) {
# representative rows: first occurrence per key
rep_idx <- match(paste(agg$internal_pu1, agg$internal_pu2),
paste(rel$internal_pu1, rel$internal_pu2))
extras <- rel[rep_idx, extra_cols, drop = FALSE]
agg <- cbind(agg, extras)
}
rel <- agg
} else {
rel <- rel[, keep, drop = FALSE]
}
rel
}
.pa_action_weights_vector <- function(actions_df,
action_weights = NULL,
subset_actions = NULL,
default_weight = 1) {
stopifnot(is.data.frame(actions_df), nrow(actions_df) > 0)
n_actions <- nrow(actions_df)
w <- rep(as.numeric(default_weight)[1], n_actions)
if (!is.null(subset_actions)) {
subset_actions <- as.integer(subset_actions)
if (anyNA(subset_actions)) stop("subset_actions contains NA.", call. = FALSE)
if (any(subset_actions < 1L | subset_actions > n_actions)) {
stop("subset_actions out of range (1..n_actions).", call. = FALSE)
}
# si se especifica subset y NO se da vector completo, el default para acciones fuera del subset suele ser 0
w[-subset_actions] <- 0
}
if (!is.null(action_weights)) {
action_weights <- as.numeric(action_weights)
if (any(!is.finite(action_weights)) || any(action_weights < 0)) {
stop("action_weights must be finite and >= 0.", call. = FALSE)
}
if (length(action_weights) == n_actions) {
w <- action_weights
} else if (!is.null(subset_actions) && length(action_weights) == length(subset_actions)) {
w[subset_actions] <- action_weights
} else {
stop(
"action_weights must have length n_actions (= ", n_actions, ") ",
"or length(subset_actions) (= ", length(subset_actions) %||% 0, ").",
call. = FALSE
)
}
}
w
}
.pa_model_frag_vars_summary <- function(x) {
if (!inherits(x, "Problem")) return(NULL)
ml <- x$data$model_list
if (is.null(ml) || !is.list(ml)) return(NULL)
# defensivo: algunos campos pueden no existir
get_int0 <- function(nm) {
v <- ml[[nm]]
if (is.null(v)) return(0L)
as.integer(v)[1]
}
out <- list(
n_y_pu = get_int0("n_y_pu"),
n_y_actions = get_int0("n_y_actions"),
n_y_interventions = get_int0("n_y_interventions"),
y_pu_offset = get_int0("y_pu_offset"),
y_actions_offset = get_int0("y_actions_offset"),
y_interventions_offset = get_int0("y_interventions_offset")
)
# si no hay ninguna y*, devuelve NULL para no ensuciar print
if ((out$n_y_pu + out$n_y_actions + out$n_y_interventions) == 0L) return(NULL)
out
}
# -------------------------------------------------------------------------
# Internal helpers multi objectives
# -------------------------------------------------------------------------
.pa_abort <- function(...) stop(paste0(...), call. = FALSE)
.pa_apply_runtime_updates_to_model <- function(model, x) {
upd <- x$data$runtime_updates %||% list()
reg <- x$data$model_registry %||% list()
# nada que hacer
if (length(upd) == 0) return(model)
bigM <- as.numeric(upd$bigM %||% 1e15)[1]
# Helper: relajar una fila para que sea redundante
relax_row <- function(i) {
s <- model$sense[i]
if (identical(s, ">=")) {
model$rhs[i] <<- -bigM
} else if (identical(s, "<=")) {
model$rhs[i] <<- bigM
} else if (identical(s, "==") || identical(s, "=")) {
model$sense[i] <<- "<="
model$rhs[i] <<- bigM
} else {
# por seguridad: si aparece algo raro, lo relajo como <= bigM
model$sense[i] <<- "<="
model$rhs[i] <<- bigM
}
invisible(NULL)
}
# 1) activar/desactivar constraints por grupos (si el registry lo soporta)
# upd$deactivate_constraints puede ser vector de ids lógicos (por nombre) o filas directas
if (!is.null(upd$deactivate_rows)) {
rows <- as.integer(upd$deactivate_rows)
rows <- rows[rows >= 1L & rows <= length(model$rhs)]
for (i in rows) relax_row(i)
}
if (!is.null(upd$deactivate_groups) && !is.null(reg$cons)) {
gs <- as.character(upd$deactivate_groups)
for (g in gs) {
rows <- reg$cons[[g]] %||% integer(0)
rows <- as.integer(rows)
rows <- rows[rows >= 1L & rows <= length(model$rhs)]
for (i in rows) relax_row(i)
}
}
# 2) epsilons: update RHS de constraints epsilon (sin cambiar estructura)
# ejemplo: upd$epsilon <- list(f2 = 0.25, f3 = 10)
if (!is.null(upd$epsilon) && !is.null(reg$cons$epsilon)) {
eps_list <- upd$epsilon
for (nm in names(eps_list)) {
rows <- reg$cons$epsilon[[nm]] %||% integer(0)
rows <- as.integer(rows)
if (length(rows) == 0) next
rhs <- as.numeric(eps_list[[nm]])[1]
# aquí asumes que la fila es del tipo f(x) >= epsilon
model$rhs[rows] <- rhs
}
}
# 3A) objetivo: override directo (vector obj completo)
# Esto es lo que necesita multiscape (weighted, etc.)
if (!is.null(upd$obj)) {
obj_new <- as.numeric(upd$obj)
if (length(obj_new) != length(model$obj)) {
stop(
"runtime_updates$obj length mismatch: ",
length(obj_new), " != ", length(model$obj),
call. = FALSE
)
}
model$obj <- obj_new
if (!is.null(upd$modelsense)) {
ms <- as.character(upd$modelsense)[1]
if (!ms %in% c("min", "max")) stop("runtime_updates$modelsense must be 'min' or 'max'.", call. = FALSE)
model$modelsense <- ms
}
}
else if (!is.null(upd$objective_template) && !is.null(reg$obj_templates)) {
tpl <- reg$obj_templates[[upd$objective_template]]
if (!is.null(tpl)) {
if (length(tpl$obj) != length(model$obj)) {
stop("Objective template length mismatch.", call. = FALSE)
}
model$obj <- tpl$obj
if (!is.null(tpl$modelsense)) model$modelsense <- tpl$modelsense
}
}
# 4) pesos AUGMECON: por ejemplo coef de slacks en obj (sin reconstruir)
if (!is.null(upd$slack_weight) && !is.null(reg$vars$slack)) {
w <- as.numeric(upd$slack_weight)[1]
slack_ids <- as.integer(reg$vars$slack)
slack_ids <- slack_ids[slack_ids >= 1L & slack_ids <= length(model$obj)]
model$obj[slack_ids] <- w
}
model
}
# -------------------------------------------------------------------------
# Internal helpers spatial relations
# -------------------------------------------------------------------------
.pa_create_problem_tabular_impl <- function(pu, features, dist_features, boundary = NULL, ...) {
dots <- list(...)
`%||%` <- function(a, b) if (!is.null(a)) a else b
pu_coords <- NULL
# helper: coerce ids to integer safely
.as_int_id <- function(x, what) {
.pa_as_int_id(x, what)
}
# keep raw PU table for downstream helpers such as add_locked_pu()
pu_raw <- pu
# =========================
# PU: validate + normalize
# =========================
assertthat::assert_that(
inherits(pu, "data.frame"),
assertthat::has_name(pu, "id"),
nrow(pu) > 0,
assertthat::noNA(pu$id)
)
pu$id <- .as_int_id(pu$id, "pu$id")
if (anyDuplicated(pu$id) != 0) stop("pu$id must be unique.", call. = FALSE)
# accept cost or monitoring_cost -> normalize to cost
if ("cost" %in% names(pu)) {
assertthat::assert_that(is.numeric(pu$cost), assertthat::noNA(pu$cost))
} else if ("monitoring_cost" %in% names(pu)) {
assertthat::assert_that(is.numeric(pu$monitoring_cost), assertthat::noNA(pu$monitoring_cost))
pu$cost <- pu$monitoring_cost
} else {
stop("pu must contain either a 'cost' column or a 'monitoring_cost' column.", call. = FALSE)
}
# IMPORTANT:
# internal contract: pu always carries locked_in / locked_out,
# defaulting to FALSE when they are not provided.
if (!("locked_in" %in% names(pu))) pu$locked_in <- FALSE
if (!("locked_out" %in% names(pu))) pu$locked_out <- FALSE
pu$locked_in <- as.logical(pu$locked_in)
pu$locked_out <- as.logical(pu$locked_out)
pu$locked_in[is.na(pu$locked_in)] <- FALSE
pu$locked_out[is.na(pu$locked_out)] <- FALSE
if (any(pu$locked_in & pu$locked_out, na.rm = TRUE)) {
stop("Some planning units are both locked_in and locked_out. Please fix pu input.", call. = FALSE)
}
# optional: store coordinates if present (tabular users)
if (all(c("x", "y") %in% names(pu))) {
pu_coords <- data.frame(
id = pu$id,
x = as.numeric(pu$x),
y = as.numeric(pu$y),
stringsAsFactors = FALSE
)
if (any(!is.finite(pu_coords$x) | !is.finite(pu_coords$y))) {
stop("pu$x/pu$y contain non-finite values.", call. = FALSE)
}
}
# internal PU table keeps the core fields needed by the model
pu <- pu[, c("id", "cost", "locked_in", "locked_out"), drop = FALSE]
pu <- pu[order(pu$id), , drop = FALSE]
# raw PU table aligned to normalized id order
pu_raw$id <- .as_int_id(pu_raw$id, "pu_raw$id")
pu_raw <- pu_raw[match(pu$id, pu_raw$id), , drop = FALSE]
# internal ids + lookup
pu$internal_id <- seq_len(nrow(pu))
pu_index <- stats::setNames(pu$internal_id, as.character(pu$id))
# =========================
# FEATURES: validate + normalize
# =========================
assertthat::assert_that(
inherits(features, "data.frame"),
assertthat::has_name(features, "id"),
nrow(features) > 0,
assertthat::noNA(features$id)
)
features$id <- .as_int_id(features$id, "features$id")
if (anyDuplicated(features$id) != 0) stop("features$id must be unique.", call. = FALSE)
if (!("name" %in% names(features))) {
features$name <- paste0("feature.", seq_len(nrow(features)))
} else {
features$name <- as.character(features$name)
assertthat::assert_that(assertthat::noNA(features$name))
if (anyDuplicated(features$name) != 0) stop("features$name must be unique.", call. = FALSE)
}
features <- features[, c("id", "name", setdiff(names(features), c("id", "name"))), drop = FALSE]
features <- features[order(features$id), , drop = FALSE]
features$internal_id <- seq_len(nrow(features))
feature_index <- stats::setNames(features$internal_id, as.character(features$id))
# =========================
# DIST_FEATURES: validate + normalize
# =========================
assertthat::assert_that(
inherits(dist_features, "data.frame"),
assertthat::has_name(dist_features, "pu"),
assertthat::has_name(dist_features, "feature"),
assertthat::has_name(dist_features, "amount"),
nrow(dist_features) > 0,
assertthat::noNA(dist_features$pu),
assertthat::noNA(dist_features$feature),
assertthat::noNA(dist_features$amount),
is.numeric(dist_features$amount),
all(is.finite(dist_features$amount)),
all(dist_features$amount >= 0)
)
dist_features$pu <- .as_int_id(dist_features$pu, "dist_features$pu")
dist_features$feature <- .as_int_id(dist_features$feature, "dist_features$feature")
if (!all(dist_features$pu %in% pu$id)) {
bad <- unique(dist_features$pu[!dist_features$pu %in% pu$id])
stop("dist_features contains unknown PU ids: ", paste(bad, collapse = ", "), call. = FALSE)
}
if (!all(dist_features$feature %in% features$id)) {
bad <- unique(dist_features$feature[!dist_features$feature %in% features$id])
stop("dist_features contains unknown feature ids: ", paste(bad, collapse = ", "), call. = FALSE)
}
dist_features <- dist_features[dist_features$amount != 0, , drop = FALSE]
key <- paste(dist_features$pu, dist_features$feature, sep = "||")
if (anyDuplicated(key) != 0) stop("There are duplicate (pu, feature) pairs in dist_features.", call. = FALSE)
dist_features$internal_pu <- unname(pu_index[as.character(dist_features$pu)])
dist_features$internal_feature <- unname(feature_index[as.character(dist_features$feature)])
dist_features <- dist_features[order(dist_features$internal_pu, dist_features$internal_feature), , drop = FALSE]
dist_features$internal_row <- seq_len(nrow(dist_features))
# =========================
# BOUNDARY: validate + normalize
# =========================
assertthat::assert_that(is.null(boundary) || inherits(boundary, "data.frame"))
if (inherits(boundary, "data.frame")) {
assertthat::assert_that(
assertthat::has_name(boundary, "id1"),
assertthat::has_name(boundary, "id2"),
assertthat::has_name(boundary, "boundary"),
assertthat::noNA(boundary$id1),
assertthat::noNA(boundary$id2),
assertthat::noNA(boundary$boundary),
is.numeric(boundary$boundary)
)
boundary$id1 <- .as_int_id(boundary$id1, "boundary$id1")
boundary$id2 <- .as_int_id(boundary$id2, "boundary$id2")
if (!all(boundary$id1 %in% pu$id) || !all(boundary$id2 %in% pu$id)) {
warning("boundary contains PU ids not present in pu; they will be removed.", call. = FALSE, immediate. = TRUE)
keep <- boundary$id1 %in% pu$id & boundary$id2 %in% pu$id
boundary <- boundary[keep, , drop = FALSE]
}
if (nrow(boundary) == 0) boundary <- NULL
}
# =========================
# useful warnings
# =========================
dif_pu <- setdiff(unique(pu$id), unique(dist_features$pu))
if (length(dif_pu) != 0L) {
warning(
paste0("The following pu's do not contain features: ", paste(dif_pu, collapse = " ")),
call. = FALSE, immediate. = TRUE
)
}
dif_features <- setdiff(unique(features$id), unique(dist_features$feature))
if (length(dif_features) != 0L) {
warning(
paste0("The following features are not represented in dist_features: ", paste(dif_features, collapse = " ")),
call. = FALSE, immediate. = TRUE
)
}
# =========================
# build Problem object
# =========================
x <- pproto(
NULL, Problem,
data = list(
pu = pu,
pu_data_raw = pu_raw,
features = features,
dist_features = dist_features,
# ---- spatial / auxiliary storage
pu_coords = pu_coords,
spatial_relations = list(),
index = list(
pu = pu_index,
feature = feature_index,
feature_name_to_id = stats::setNames(features$id, features$name)
),
meta = list(
dist_features_meaning = "baseline_amount",
dist_benefit_meaning = "delta_by_default"
),
# workflow placeholders
actions = NULL,
dist_actions = NULL,
dist_benefit = NULL,
locked_actions = NULL,
targets = NULL,
objective = NULL,
decisions = NULL,
solver = NULL
)
)
# =========================
# boundary -> spatial relation ("boundary")
# =========================
if (!is.null(boundary) && inherits(boundary, "data.frame") && nrow(boundary) > 0) {
rel <- data.frame(
internal_pu1 = unname(pu_index[as.character(boundary$id1)]),
internal_pu2 = unname(pu_index[as.character(boundary$id2)]),
weight = as.numeric(boundary$boundary),
source = "boundary_table",
stringsAsFactors = FALSE
)
if (anyNA(rel$internal_pu1) || anyNA(rel$internal_pu2)) {
stop("boundary contains PU ids not present in pu (after filtering).", call. = FALSE)
}
rel <- .pa_validate_relation(rel, n_pu = nrow(pu), allow_self = FALSE, dup_agg = "sum")
rel$relation_name <- "boundary"
if (is.null(x$data$spatial_relations) || !is.list(x$data$spatial_relations)) {
x$data$spatial_relations <- list()
}
x$data$spatial_relations[["boundary"]] <- rel
}
x
}
# -------------------------------------------------------------------------
# Internal helpers objective relations
# -------------------------------------------------------------------------
.pa_register_objective <- function(
x,
alias,
objective_id,
model_type,
objective_args = list(),
sense = c("min", "max")
) {
stopifnot(inherits(x, "Problem"))
if (is.null(alias)) return(x)
alias <- as.character(alias)[1]
if (is.na(alias) || !nzchar(alias)) {
stop("alias must be a non-empty string.", call. = FALSE)
}
objective_id <- as.character(objective_id)[1]
if (is.na(objective_id) || !nzchar(objective_id)) {
stop("objective_id must be a non-empty string.", call. = FALSE)
}
model_type <- as.character(model_type)[1]
if (is.na(model_type) || !nzchar(model_type)) {
stop("model_type must be a non-empty string.", call. = FALSE)
}
sense <- match.arg(sense)
if (is.null(objective_args)) {
objective_args <- list()
}
if (!is.list(objective_args)) {
stop("objective_args must be a list.", call. = FALSE)
}
if (is.null(x$data$objectives) || !is.list(x$data$objectives)) {
x$data$objectives <- list()
}
# prevent duplicated aliases
if (!is.null(x$data$objectives[[alias]])) {
stop(
"Objective alias '", alias, "' already exists. ",
"Use a different alias.",
call. = FALSE
)
}
x$data$objectives[[alias]] <- list(
alias = alias,
objective_id = objective_id,
model_type = model_type,
objective_args = objective_args,
sense = sense,
created_at = as.character(Sys.time())
)
# keep deterministic ordering by alias
x$data$objectives <- x$data$objectives[sort(names(x$data$objectives))]
# if a model already exists, mark dirty
if (!is.null(x$data$model_ptr)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$model_dirty <- TRUE
}
x
}
# internal registry for MO objectives inside Problem
# .pa_init_objectives <- function(x) {
# if (is.null(x$data$objectives) || !is.list(x$data$objectives)) {
# x$data$objectives <- list()
# }
# x
# }
# .pa_get_objective_specs <- function(x) {
# if (is.null(x$data$objectives)) return(list())
# x$data$objectives
# }
# .pa_set_objective_linear <- function(x, obj, modelsense = c("min", "max")) {
# stopifnot(inherits(x, "Problem"))
# modelsense <- match.arg(modelsense)
#
# # guarda runtime update para que .pa_apply_runtime_updates_to_model() lo aplique
# x$data$runtime_updates <- x$data$runtime_updates %||% list()
# x$data$runtime_updates$obj <- as.numeric(obj)
# x$data$runtime_updates$modelsense <- modelsense
#
# # marca "dirty" para que se regenere model_list desde ptr si aplica (o solo runtime update)
# x$data$meta$model_dirty <- TRUE
# x
# }
# .pa_mark_mo_needs <- function(x, needs) {
# stopifnot(inherits(x, "Problem"))
# x$data$mo <- x$data$mo %||% list()
# x$data$mo$needs <- utils::modifyList(x$data$mo$needs %||% list(), needs)
# x$data$meta$model_dirty <- TRUE
# x
# }
.pa_fast_extract <- function(x, y, fun = c("sum", "mean", "max")) {
fun <- match.arg(fun)
stopifnot(inherits(x, "terra::SpatRaster") || inherits(x, "SpatRaster"))
stopifnot(inherits(y, "terra::SpatVector") || inherits(y, "SpatVector") || inherits(y, "sf"))
if (inherits(y, "SpatVector")) {
if (!requireNamespace("sf", quietly = TRUE)) stop("Need 'sf' to convert SpatVector -> sf.", call. = FALSE)
y <- sf::st_as_sf(y)
}
out <- matrix(NA_real_, nrow = nrow(y), ncol = terra::nlyr(x))
colnames(out) <- make.unique(names(x))
geomc <- as.character(sf::st_geometry_type(y, by_geometry = TRUE))
# points
point_idx <- grepl("POINT", geomc, fixed = TRUE)
if (any(point_idx)) {
ex <- terra::extract(x = x, y = sf::st_coordinates(y[point_idx, , drop = FALSE]))
out[point_idx, ] <- as.matrix(ex[, -1, drop = FALSE]) # drop ID column
}
# lines
line_idx <- grepl("LINE", geomc, fixed = TRUE)
if (any(line_idx)) {
fun2 <- switch(fun, mean = mean, sum = sum, max = max)
out[line_idx, ] <- as.matrix(
terra::extract(
x = x,
y = terra::vect(y[line_idx, , drop = FALSE]),
ID = FALSE,
touches = TRUE,
fun = fun2,
na.rm = TRUE
)
)
}
# polygons (prioritizr-like)
poly_idx <- grepl("POLYGON", geomc, fixed = TRUE)
if (any(poly_idx)) {
if (!requireNamespace("exactextractr", quietly = TRUE)) {
stop("Polygon feature extraction requires 'exactextractr'.", call. = FALSE)
}
# IMPORTANT: avoid mutating user's objects
y2 <- y[poly_idx, , drop = FALSE]
x2 <- x
# (this is just to silence CRS/proj warnings like prioritizr; extraction uses coordinates)
sf::st_crs(y2) <- sf::st_crs(NA_character_)
terra::crs(x2) <- NA_character_
out[poly_idx, ] <- as.matrix(
exactextractr::exact_extract(
x2,
y2,
fun = fun,
max_cells_in_memory = 1e6,
progress = FALSE
)
)
}
out[!is.finite(out)] <- 0
out[abs(out) < 1e-10] <- 0
out
}
# -------------------------------------------------------------------------
# Internal helpers SPATIAL relations
# -------------------------------------------------------------------------
.pa_has_sf <- function() requireNamespace("sf", quietly = TRUE)
.pa_ensure_pu_index <- function(x) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$pu) || !inherits(x$data$pu, "data.frame")) {
stop("x$data$pu is missing. Create the problem with create_problem().", call. = FALSE)
}
if (is.null(x$data$pu$internal_id)) x$data$pu$internal_id <- seq_len(nrow(x$data$pu))
if (is.null(x$data$pu$id)) {
stop("x$data$pu must contain column 'id' (planning unit id).", call. = FALSE)
}
x$data$pu$id <- as.integer(x$data$pu$id)
x$data$pu$internal_id <- as.integer(x$data$pu$internal_id)
if (anyNA(x$data$pu$id) || anyNA(x$data$pu$internal_id)) {
stop("x$data$pu$id/internal_id contain NA after coercion.", call. = FALSE)
}
if (anyDuplicated(x$data$pu$internal_id) != 0) stop("x$data$pu$internal_id must be unique.", call. = FALSE)
if (anyDuplicated(x$data$pu$id) != 0) stop("x$data$pu$id must be unique.", call. = FALSE)
if (is.null(x$data$index) || !is.list(x$data$index)) x$data$index <- list()
x$data$index$pu <- stats::setNames(x$data$pu$internal_id, as.character(x$data$pu$id))
x
}
.pa_store_relation <- function(x, rel, name) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$spatial_relations) || !is.list(x$data$spatial_relations)) {
x$data$spatial_relations <- list()
}
if (name %in% names(x$data$spatial_relations)) {
stop("Spatial relation '", name, "' already exists. Use a new name or rebuild ",
"from the problem before this relation to change it.", call. = FALSE)
}
x$data$spatial_relations[[name]] <- rel
x
}
.pa_coords_from_input <- function(x, coords = NULL) {
stopifnot(inherits(x, "Problem"))
if (!is.null(coords)) {
if (inherits(coords, "data.frame")) {
if (!all(c("id", "x", "y") %in% names(coords))) {
stop("coords data.frame must contain columns id, x, y.", call. = FALSE)
}
out <- coords[, c("id", "x", "y")]
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
if (is.matrix(coords)) {
if (ncol(coords) < 2) stop("coords matrix must have at least 2 columns (x,y).", call. = FALSE)
out <- data.frame(id = x$data$pu$id, x = coords[, 1], y = coords[, 2])
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
stop("Unsupported coords type. Use data.frame(id,x,y) or a matrix with 2 columns.", call. = FALSE)
}
# NEW fallback: x$data$pu_coords
if (!is.null(x$data$pu_coords) && inherits(x$data$pu_coords, "data.frame")) {
pc <- x$data$pu_coords
if (all(c("id", "x", "y") %in% names(pc))) {
out <- pc[, c("id", "x", "y")]
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
}
# fallback: try x$data$pu columns
if (all(c("x", "y") %in% names(x$data$pu))) {
out <- data.frame(id = x$data$pu$id, x = x$data$pu$x, y = x$data$pu$y)
out$id <- as.integer(out$id)
out$x <- as.numeric(out$x)
out$y <- as.numeric(out$y)
return(out)
}
stop(
"No coordinates available. Provide coords=data.frame(id,x,y) or store x$data$pu_coords (id,x,y), or add x$data$pu$x/y.",
call. = FALSE
)
}
.pa_get_pu_sf_aligned <- function(x, pu_sf = NULL, arg_name = "pu_sf") {
stopifnot(inherits(x, "Problem"))
x <- .pa_ensure_pu_index(x)
if (is.null(pu_sf)) pu_sf <- x$data$pu_sf
if (is.null(pu_sf)) {
stop(
arg_name, " is NULL and x$data$pu_sf is missing.\n",
"Provide ", arg_name, " (sf polygons with an 'id' column) or make sure create_problem() stored x$data$pu_sf.",
call. = FALSE
)
}
if (!requireNamespace("sf", quietly = TRUE)) {
stop("This function requires the 'sf' package.", call. = FALSE)
}
if (!inherits(pu_sf, "sf")) stop(arg_name, " must be an sf object.", call. = FALSE)
if (!("id" %in% names(pu_sf))) stop(arg_name, " must contain an 'id' column.", call. = FALSE)
pu_sf$id <- as.integer(pu_sf$id)
# align to x$data$pu$id (critical)
ord <- match(x$data$pu$id, pu_sf$id)
if (anyNA(ord)) {
missing_ids <- x$data$pu$id[is.na(ord)]
stop(
arg_name, "$id does not match x$data$pu$id (some ids missing). Missing: ",
paste(utils::head(missing_ids, 20), collapse = ", "),
if (length(missing_ids) > 20) " ..." else "",
call. = FALSE
)
}
pu_sf[ord, , drop = FALSE]
}
.pa_rbind_fill <- function(a, b) {
stopifnot(inherits(a, "data.frame"), inherits(b, "data.frame"))
cols <- union(names(a), names(b))
for (cc in setdiff(cols, names(a))) a[[cc]] <- NA
for (cc in setdiff(cols, names(b))) b[[cc]] <- NA
a <- a[, cols, drop = FALSE]
b <- b[, cols, drop = FALSE]
rbind(a, b)
}
.pa_swap_edges <- function(rel) {
out <- rel
out$internal_pu1 <- rel$internal_pu2
out$internal_pu2 <- rel$internal_pu1
if ("pu1" %in% names(rel) && "pu2" %in% names(rel)) {
out$pu1 <- rel$pu2
out$pu2 <- rel$pu1
}
out
}
# -------------------------------------------------------------------------
# Needs flags (feature requirements) for build
# -------------------------------------------------------------------------
.pa_needs_default <- function() {
list(
z = FALSE, # z vars (representation)
y_pu = FALSE, # PU fragmentation auxiliaries
y_action = FALSE, # action fragmentation auxiliaries
y_intervention = FALSE, # intervention fragmentation auxiliaries
u_intervention = FALSE # intervention extra vars (if applicable)
)
}
.pa_build_model_init_needs <- function(x) {
stopifnot(inherits(x, "Problem"))
if (is.null(x$data$model_args) || !is.list(x$data$model_args)) x$data$model_args <- list()
needs <- x$data$model_args$needs
if (is.null(needs) || !is.list(needs)) needs <- list()
# merge defaults without overwriting existing values
def <- .pa_needs_default()
for (nm in names(def)) {
if (is.null(needs[[nm]])) needs[[nm]] <- def[[nm]]
}
x$data$model_args$needs <- needs
x
}
.pa_build_model_set_needs_from_objective <- function(x) {
stopifnot(inherits(x, "Problem"))
args <- x$data$model_args %||% list()
mtype <- args$model_type %||% "minimizeCosts"
oargs <- args$objective_args %||% list()
raw_needs <- args$needs %||% list()
needs <- .pa_needs_default()
# decisión de diseño actual: z siempre disponible
needs$z <- TRUE
# primero respetamos overrides explícitos si vienen dados
if (!is.null(raw_needs$z)) needs$z <- isTRUE(raw_needs$z)
if (!is.null(raw_needs$y_pu)) needs$y_pu <- isTRUE(raw_needs$y_pu)
if (!is.null(raw_needs$y_action)) needs$y_action <- isTRUE(raw_needs$y_action)
if (!is.null(raw_needs$y_intervention)) needs$y_intervention <- isTRUE(raw_needs$y_intervention)
if (!is.null(raw_needs$u_intervention)) needs$u_intervention <- isTRUE(raw_needs$u_intervention)
# luego inferimos solo lo que no vino explícito
if (is.null(raw_needs$y_pu)) {
needs$y_pu <- identical(mtype, "minimizeFragmentation")
}
if (is.null(raw_needs$y_action)) {
needs$y_action <- identical(mtype, "minimizeActionFragmentation")
}
if (is.null(raw_needs$y_intervention)) {
needs$y_intervention <- identical(mtype, "minimizeInterventionFragmentation")
}
if (is.null(raw_needs$u_intervention)) {
needs$u_intervention <- identical(mtype, "minimizeInterventionImpact")
}
# propagación explícita de metadatos estructurales necesarios
if (isTRUE(needs$y_pu) || isTRUE(needs$y_action) || isTRUE(needs$y_intervention)) {
if (is.null(raw_needs$relation_name)) {
needs$relation_name <- as.character(oargs$relation_name %||% "boundary")[1]
}
}
if (isTRUE(needs$y_action)) {
if (is.null(raw_needs$actions_to_use)) {
needs$actions_to_use <- oargs$actions_to_use %||% oargs$actions %||% NULL
}
}
if (isTRUE(needs$u_intervention)) {
if (is.null(raw_needs$u_intervention_actions)) {
needs$u_intervention_actions <- oargs$actions %||% NULL
}
}
# preserva metadatos extra útiles para MO
extra_fields <- setdiff(names(raw_needs), names(needs))
if (length(extra_fields) > 0L) {
for (nm in extra_fields) {
needs[[nm]] <- raw_needs[[nm]]
}
}
needs$z <- isTRUE(needs$z)
needs$y_pu <- isTRUE(needs$y_pu)
needs$y_action <- isTRUE(needs$y_action)
needs$y_intervention <- isTRUE(needs$y_intervention)
needs$u_intervention <- isTRUE(needs$u_intervention)
x$data$model_args$needs <- needs
x
}
.pa_build_model_prepare_needs_cpp <- function(x) {
stopifnot(inherits(x, "Problem"))
.pa_abort <- function(...) stop(paste0(...), call. = FALSE)
op <- x$data$model_ptr
args <- x$data$model_args %||% list()
needs <- args$needs %||% list()
oargs <- args$objective_args %||% list()
mo_mode <- isTRUE(args$mo_mode)
if (isTRUE(mo_mode) && isTRUE(needs$y_intervention)) {
.pa_abort(
"MO phase 1 does not support preparing y_intervention in the shared superset yet."
)
}
if (!isTRUE(needs$y_pu) &&
!isTRUE(needs$y_action) &&
!isTRUE(needs$y_intervention) &&
!isTRUE(needs$u_intervention)) {
return(x)
}
x$data$model_registry <- x$data$model_registry %||% list()
x$data$model_registry$vars <- x$data$model_registry$vars %||% list()
.pa_prepare_relation_model <- function(rel) {
rel <- rel[, c(
"internal_pu1","internal_pu2","weight",
intersect(names(rel), c("directed","distance","source","relation_name"))
), drop = FALSE]
rel$internal_pu1 <- as.integer(rel$internal_pu1)
rel$internal_pu2 <- as.integer(rel$internal_pu2)
rel$weight <- as.numeric(rel$weight)
rel <- rel[order(rel$internal_pu1, rel$internal_pu2), , drop = FALSE]
rel$internal_edge <- seq_len(nrow(rel))
rel
}
rel_model <- NULL
if (isTRUE(needs$y_pu) ||
isTRUE(needs$y_action) ||
isTRUE(needs$y_intervention)) {
rel_name <- as.character(needs$relation_name %||% oargs$relation_name %||% "boundary")[1]
rels <- x$data$spatial_relations
if (is.null(rels) || is.null(rels[[rel_name]])) {
.pa_abort("prepare_needs: missing spatial relation '", rel_name, "'.")
}
x$data$spatial_relations_model <- x$data$spatial_relations_model %||% list()
if (is.null(x$data$spatial_relations_model[[rel_name]])) {
x$data$spatial_relations_model[[rel_name]] <- .pa_prepare_relation_model(rels[[rel_name]])
}
rel_model <- x$data$spatial_relations_model[[rel_name]]
}
# ---- y_pu
if (isTRUE(needs$y_pu)) {
if (!exists("rcpp_prepare_objective_min_fragmentation", mode = "function")) {
.pa_abort("Missing rcpp_prepare_objective_min_fragmentation() in the package.")
}
res <- rcpp_prepare_objective_min_fragmentation(
x = op,
relation_data = rel_model
)
x$data$model_registry$vars$y_pu <- res
}
# ---- y_action
if (isTRUE(needs$y_action)) {
if (!exists("rcpp_prepare_objective_min_fragmentation_actions", mode = "function")) {
.pa_abort("Missing rcpp_prepare_objective_min_fragmentation_actions() in the package.")
}
if (is.null(x$data$dist_actions_model) || !inherits(x$data$dist_actions_model, "data.frame")) {
.pa_abort("prepare_needs: y_action requires x$data$dist_actions_model (model-ready).")
}
if (nrow(x$data$dist_actions_model) == 0) {
.pa_abort("prepare_needs: y_action requires action variables, but dist_actions_model has 0 rows.")
}
actions_to_use_raw <- needs$actions_to_use %||% oargs$actions_to_use %||% oargs$actions %||% NULL
actions_to_use <- NULL
if (!is.null(actions_to_use_raw)) {
act_subset <- .pa_resolve_action_subset(x, subset = actions_to_use_raw)
actions_to_use <- as.integer(act_subset$internal_id)
}
res <- rcpp_prepare_objective_min_fragmentation_actions(
x = op,
dist_actions_data = x$data$dist_actions_model,
relation_data = rel_model,
actions_to_use = actions_to_use,
block_name = "fragmentation_actions",
tag = ""
)
x$data$model_registry$vars$y_action <- res
}
# ---- u_intervention for min_intervention_impact
if (isTRUE(needs$u_intervention)) {
if (!exists("rcpp_prepare_objective_min_intervention_impact", mode = "function")) {
.pa_abort("Missing rcpp_prepare_objective_min_intervention_impact() in the package.")
}
if (is.null(x$data$dist_actions_model) || !inherits(x$data$dist_actions_model, "data.frame")) {
.pa_abort("prepare_needs: u_intervention requires x$data$dist_actions_model (model-ready).")
}
if (nrow(x$data$dist_actions_model) == 0) {
.pa_abort("prepare_needs: u_intervention requires action variables, but dist_actions_model has 0 rows.")
}
if (is.null(x$data$dist_features) || !inherits(x$data$dist_features, "data.frame")) {
.pa_abort("prepare_needs: u_intervention requires x$data$dist_features.")
}
if (nrow(x$data$dist_features) == 0) {
.pa_abort("prepare_needs: u_intervention requires non-empty x$data$dist_features.")
}
actions_chr <- needs$u_intervention_actions %||% oargs$actions %||% NULL
if (is.null(actions_chr) || length(actions_chr) == 0) {
.pa_abort(
"prepare_needs: u_intervention requires a non-empty shared action subset.\n",
"For MO phase 1, all intervention_impact objectives must use the same actions."
)
}
act_subset <- .pa_resolve_action_subset(x, subset = actions_chr)
acts_internal <- as.integer(act_subset$internal_id)
if (length(acts_internal) == 0) {
.pa_abort("prepare_needs: u_intervention action subset resolved to zero actions.")
}
subset_key <- .pa_subset_to_string(act_subset$id)
impact_col <- as.character(oargs$impact_col %||% "amount")[1]
if (!(impact_col %in% names(x$data$dist_features))) {
impact_col <- "amount"
if (!("amount" %in% names(x$data$dist_features))) {
.pa_abort(
"prepare_needs: could not find a valid impact column in x$data$dist_features."
)
}
}
res <- rcpp_prepare_objective_min_intervention_impact(
x = op,
pu_data = x$data$pu,
dist_actions_data = x$data$dist_actions_model,
dist_features_data = x$data$dist_features,
subset_key = subset_key,
impact_col = impact_col,
features_to_use = integer(0),
actions_to_use = acts_internal,
internal_feature_col = "internal_feature",
block_name = "objective_min_intervention_impact",
tag = if (isTRUE(mo_mode)) "from=prepare_needs_cpp;mode=MO" else ""
)
x$data$model_registry$vars$u_intervention_impact <- res
}
x
}
.pa_deepcopy_data <- function(d) {
# R vectors and data frames use copy-on-modification. Serializing all input
# tables for every setter creates large transient buffers unnecessarily.
# Clone reference objects explicitly; preserve list attributes and scopes.
if (is.environment(d) || isS4(d)) return(unserialize(serialize(d, NULL)))
if (is.list(d) && !is.data.frame(d)) {
out <- lapply(d, .pa_deepcopy_data)
attributes(out) <- attributes(d)
return(out)
}
d
}
.pa_clone_data <- function(x, drop_model = TRUE) {
stopifnot(inherits(x, "Problem"))
# crear un NUEVO proto heredando de x
y <- pproto(NULL, x)
# ahora sí, sustituir data por una copia profunda
d <- x$data
if (isTRUE(drop_model)) {
d$model_ptr <- NULL
d$model_index <- NULL
d$model_list <- NULL
}
y$data <- .pa_deepcopy_data(d)
if (isTRUE(drop_model)) {
y$data$model_ptr <- NULL
y$data$model_index <- NULL
y$data$model_list <- NULL
y$data$has_model <- FALSE
if (is.null(y$data$meta) || !is.list(y$data$meta)) {
y$data$meta <- list()
}
y$data$meta$model_dirty <- TRUE
}
y
}
.pa_log_add <- function(x, key, value) {
stopifnot(inherits(x, "Problem"))
key <- as.character(key)[1]
if (is.na(key) || !nzchar(key)) {
stop("`key` must be a non-empty string.", call. = FALSE)
}
value <- as.numeric(value)[1]
if (!is.finite(value)) {
stop("`value` must be a finite numeric scalar.", call. = FALSE)
}
if (is.null(x$data$build_log) || !is.list(x$data$build_log)) {
x$data$build_log <- list()
}
old <- x$data$build_log[[key]] %||% 0
x$data$build_log[[key]] <- old + value
x
}
.pa_resolve_action_subset <- function(x, subset = NULL) {
stopifnot(inherits(x, "Problem"))
acts <- x$data$actions
if (is.null(acts) || !inherits(acts, "data.frame") || nrow(acts) == 0) {
stop("No actions available in x$data$actions.", call. = FALSE)
}
if (!all(c("id", "internal_id") %in% names(acts))) {
stop("x$data$actions must contain columns 'id' and 'internal_id'.", call. = FALSE)
}
# NULL = all actions
if (is.null(subset)) {
out <- acts[, c("id", "internal_id"), drop = FALSE]
if ("action_set" %in% names(acts)) out$action_set <- acts$action_set
return(out)
}
subset <- as.character(subset)
subset <- unique(subset[!is.na(subset) & nzchar(subset)])
if (length(subset) == 0) {
stop("subset must contain at least one non-empty value, or be NULL.", call. = FALSE)
}
hit_id <- acts$id %in% subset
hit_set <- rep(FALSE, nrow(acts))
if ("action_set" %in% names(acts)) {
hit_set <- acts$action_set %in% subset
}
keep <- hit_id | hit_set
if (!any(keep)) {
stop(
"subset did not match any action ids",
if ("action_set" %in% names(acts)) " or action_set values" else "",
".",
call. = FALSE
)
}
out <- acts[keep, c("id", "internal_id"), drop = FALSE]
if ("action_set" %in% names(acts)) out$action_set <- acts$action_set[keep]
rownames(out) <- NULL
out
}
#' @include internal.R
NULL
# -------------------------------------------------------------------------
# Internal helpers for normalized atomic objectives
# -------------------------------------------------------------------------
.pa_set_active_and_register_objective <- function(
x,
model_type,
objective_id,
objective_args = list(),
sense = c("min", "max"),
alias = NULL
) {
stopifnot(inherits(x, "Problem"))
sense <- match.arg(sense)
single_defined <- isTRUE(x$data$meta$single_objective_defined) ||
(!is.null(x$data$model_args$objective_id) &&
length(x$data$objectives %||% list()) == 0L)
if (is.null(alias) && single_defined) {
stop("A single-objective definition already exists. Use distinct aliases for ",
"multi-objective planning or rebuild from the problem before this objective.",
call. = FALSE)
}
x <- .pa_clone_data(x)
if (is.null(x$data$model_args) || !is.list(x$data$model_args)) {
x$data$model_args <- list()
}
if (is.null(alias) || !single_defined) {
x$data$model_args$model_type <- as.character(model_type)[1]
x$data$model_args$objective_id <- as.character(objective_id)[1]
x$data$model_args$objective_args <- objective_args
}
if (is.null(alias)) {
x$data$meta <- x$data$meta %||% list()
x$data$meta$single_objective_defined <- TRUE
}
x <- .pa_register_objective(
x = x,
alias = alias,
objective_id = objective_id,
model_type = model_type,
objective_args = objective_args,
sense = sense
)
x
}
.pa_resolve_feature_subset <- function(x, features = NULL) {
stopifnot(inherits(x, "Problem"))
feats <- x$data$features
if (is.null(feats) || !inherits(feats, "data.frame") || nrow(feats) == 0) {
stop("No features available in x$data$features.", call. = FALSE)
}
if (!all(c("id", "internal_id") %in% names(feats))) {
stop("x$data$features must contain columns 'id' and 'internal_id'.", call. = FALSE)
}
if (is.null(features)) {
out <- feats[, c("id", "internal_id"), drop = FALSE]
if ("name" %in% names(feats)) out$name <- feats$name
return(out)
}
vals <- unique(features)
vals <- vals[!is.na(vals)]
if (length(vals) == 0) {
stop("features must contain at least one non-missing value, or be NULL.", call. = FALSE)
}
hit_id <- feats$id %in% vals
hit_name <- rep(FALSE, nrow(feats))
if ("name" %in% names(feats)) {
hit_name <- as.character(feats$name) %in% as.character(vals)
}
keep <- hit_id | hit_name
if (!any(keep)) {
stop(
"features did not match any feature ids",
if ("name" %in% names(feats)) " or feature names" else "",
".",
call. = FALSE
)
}
out <- feats[keep, c("id", "internal_id"), drop = FALSE]
if ("name" %in% names(feats)) out$name <- feats$name[keep]
rownames(out) <- NULL
out
}
.pa_subset_to_string <- function(subset) {
if (is.null(subset)) return(NA_character_)
subset <- as.character(subset)
subset <- unique(subset[!is.na(subset) & nzchar(subset)])
if (length(subset) == 0) return(NA_character_)
paste(sort(subset), collapse = "|")
}
.pa_add_feature_labels <- function(df,
features_df,
feature_col = "feature",
internal_feature_col = "internal_feature",
out_col = "feature_name") {
stopifnot(is.data.frame(df), is.data.frame(features_df))
if (nrow(df) == 0) {
df[[out_col]] <- character(0)
return(df)
}
if (!("name" %in% names(features_df))) {
df[[out_col]] <- rep(NA_character_, nrow(df))
return(df)
}
out <- rep(NA_character_, nrow(df))
# Prefer external feature id
if (feature_col %in% names(df) && "id" %in% names(features_df)) {
m <- match(df[[feature_col]], features_df$id)
ok <- !is.na(m)
out[ok] <- as.character(features_df$name[m[ok]])
}
# Fill remaining using internal id
if (anyNA(out) &&
internal_feature_col %in% names(df) &&
"internal_id" %in% names(features_df)) {
miss <- which(is.na(out))
m2 <- match(df[[internal_feature_col]][miss], features_df$internal_id)
ok2 <- !is.na(m2)
out[miss[ok2]] <- as.character(features_df$name[m2[ok2]])
}
df[[out_col]] <- out
df
}
.pa_add_action_labels <- function(df,
actions_df,
action_col = "action",
internal_action_col = "internal_action",
out_col = "action_name") {
stopifnot(is.data.frame(df), is.data.frame(actions_df))
if (nrow(df) == 0) {
df[[out_col]] <- character(0)
return(df)
}
if (!("name" %in% names(actions_df))) {
df[[out_col]] <- rep(NA_character_, nrow(df))
return(df)
}
out <- rep(NA_character_, nrow(df))
# Prefer external action id
if (action_col %in% names(df) && "id" %in% names(actions_df)) {
m <- match(df[[action_col]], actions_df$id)
ok <- !is.na(m)
out[ok] <- as.character(actions_df$name[m[ok]])
}
# Fill remaining using internal id
if (anyNA(out) &&
internal_action_col %in% names(df) &&
"internal_id" %in% names(actions_df)) {
miss <- which(is.na(out))
m2 <- match(df[[internal_action_col]][miss], actions_df$internal_id)
ok2 <- !is.na(m2)
out[miss[ok2]] <- as.character(actions_df$name[m2[ok2]])
}
df[[out_col]] <- out
df
}
.pa_solve_single_problem <- function(x, ...) {
assertthat::assert_that(inherits(x, "Problem"))
# ---- gather stored solve args (defaults + stored)
dots <- list(...)
# consideramos “ya configurado” si solve_args existe y tiene al menos un campo no nulo
has_stored_args <- !is.null(x$data$solve_args) &&
length(x$data$solve_args) > 0 &&
any(!vapply(x$data$solve_args, is.null, logical(1)))
sa <- do.call(.pa_get_solve_args, c(list(x = x), dots))
solver <- sa$solver %||% "auto"
gap_limit <- sa$gap_limit
time_limit <- sa$time_limit
solution_limit <- sa$solution_limit
cores <- sa$cores
verbose <- sa$verbose
name_output_file <- sa$name_output_file
output_file <- sa$output_file
solver_params_user <- sa$solver_params %||% list()
# ---- autodetect solver if requested
if (identical(solver, "auto") || identical(solver, "") || is.null(solver)) {
if (requireNamespace("gurobi", quietly = TRUE) &&
isTRUE(available_to_solve("gurobi"))) {
solver <- "gurobi"
} else if (requireNamespace("rcbc", quietly = TRUE) &&
isTRUE(available_to_solve("cbc"))) {
solver <- "cbc"
} else if (requireNamespace("Rcplex", quietly = TRUE) &&
isTRUE(available_to_solve("cplex"))) {
solver <- "cplex"
} else if (requireNamespace("Rsymphony", quietly = TRUE) &&
isTRUE(available_to_solve("symphony"))) {
solver <- "symphony"
} else {
stop("No optimization problem solvers available on this system.", call. = FALSE)
}
} else {
if (!solver %in% c("gurobi", "cbc", "symphony", "cplex")) {
stop("Solver not supported: ", solver, call. = FALSE)
}
if (identical(solver, "gurobi") &&
(!requireNamespace("gurobi", quietly = TRUE) ||
!isTRUE(available_to_solve("gurobi")))) {
stop("Gurobi solver not available (package/license not found).", call. = FALSE)
}
if (identical(solver, "cbc") &&
(!requireNamespace("rcbc", quietly = TRUE) ||
!isTRUE(available_to_solve("cbc")))) {
stop("CBC solver not available (rcbc not installed or CBC not available).", call. = FALSE)
}
if (identical(solver, "symphony") &&
(!requireNamespace("Rsymphony", quietly = TRUE) ||
!isTRUE(available_to_solve("symphony")))) {
stop("SYMPHONY solver not available (Rsymphony not installed).", call. = FALSE)
}
if (identical(solver, "cplex") &&
(!requireNamespace("Rcplex", quietly = TRUE) ||
!isTRUE(available_to_solve("cplex")))) {
stop("CPLEX solver not available (Rcplex not installed/licensed).", call. = FALSE)
}
}
caps <- .pa_apply_solver_capabilities(
solver = solver,
cores = cores,
solution_limit = solution_limit,
output_file = output_file,
name_output_file = name_output_file,
solver_params = solver_params_user,
warn = TRUE
)
cores <- caps$cores
solution_limit <- caps$solution_limit
output_file <- caps$output_file
name_output_file <- caps$name_output_file
solver_params_user <- caps$solver_params
if (identical(solver, "gurobi") &&
isTRUE(output_file) &&
is.null(name_output_file)) {
stop("A non-empty log_file is required when write_log = TRUE.", call. = FALSE)
}
# ---- ensure model is built
if (is.null(x$data$model_ptr) || isTRUE(x$data$meta$model_dirty)) {
x <- .pa_build_model(x)
x$data$meta$model_dirty <- FALSE
}
# ---- model list from pointer
model <- .pa_model_from_ptr(
x$data$model_ptr,
args = x$data$model_args %||% list(),
drop_triplets = TRUE
)
# ---- APPLY SUPERSET RUNTIME UPDATES (solver-agnostic)
model <- .pa_apply_runtime_updates_to_model(model, x)
mo_numeric <- isTRUE(x$data$runtime_updates$mo_numeric)
initial_solution <- x$data$runtime_updates$start
if (!is.null(initial_solution)) {
if (length(initial_solution) != length(model$obj)) {
stop("Runtime initial solution length does not match the model.", call. = FALSE)
}
initial_solution <- as.numeric(initial_solution)
binary <- model$vtype == "B"
initial_solution[binary] <- round(initial_solution[binary])
}
objective_scale <- if (mo_numeric) .pa_positive_objective_scale(model$obj) else 1
model$obj <- model$obj * objective_scale
# Constant ecological objectives can create empty constraint rows. Check
# their feasibility explicitly: some solver adapters omit such rows.
empty_rows <- Matrix::rowSums(abs(model$A)) == 0
impossible <- empty_rows & (
(model$sense == "<=" & model$rhs < 0) |
(model$sense == ">=" & model$rhs > 0) |
(model$sense %in% c("=", "==") & model$rhs != 0)
)
if (any(impossible)) {
stop("Solver status: infeasible (unsatisfied constant constraint).", call. = FALSE)
}
# ---- pack args into Solution metadata
solve_args <- list(
solver = solver,
gap = gap_limit,
timelimit = time_limit,
cores = cores,
verbose = verbose,
solution_limit = solution_limit,
name_output_file = name_output_file,
output_file = output_file,
solver_params = solver_params_user
)
if (mo_numeric) solve_args$objective_scale <- objective_scale
if (!is.null(initial_solution)) solve_args$warm_start <- TRUE
# ------------------------------------------------------------
# 1) Call solver -> return unified payload:
# objval, solvec, gap, status_code, runtime
# ------------------------------------------------------------
objval <- NA_real_
solvec <- numeric(0)
gap <- NA_real_
status_code <- 999L
runtime <- NA_real_
if (solver == "gurobi") {
model$sense <- replace(model$sense, model$sense == "==", "=")
model$lb <- model$bounds$lower$val
model$ub <- model$bounds$upper$val
if (!is.null(initial_solution)) model$start <- initial_solution
params <- list(
LogToConsole = as.integer(verbose),
NodefileStart = 0.5,
MIPGap = gap_limit,
TimeLimit = time_limit
)
if (mo_numeric) {
params <- c(params, list(FeasibilityTol = 1e-9, IntFeasTol = 1e-9,
OptimalityTol = 1e-9, MIPGapAbs = 0))
}
if (!is.null(cores)) params$Threads <- cores
if (isTRUE(output_file)) params$LogFile <- name_output_file
if (isTRUE(solution_limit)) params$SolutionLimit <- 1
if (!is.null(model$args$curve) && !is.null(model$args$segments) && model$args$curve != 1) {
params$FuncPieces <- 1
params$FuncPieceLength <- round(1 / as.numeric(model$args$segments), digits = 1)
}
params <- utils::modifyList(params, solver_params_user)
if (mo_numeric) solve_args$effective_solver_params <- params
sol <- gurobi::gurobi(model, params)
# status_code <- dplyr::case_when(
# sol$status == "OPTIMAL" ~ 0L,
# sol$status %in% c("INF_OR_UNBD", "INFEASIBLE", "UNBOUNDED") ~ 1L,
# (sol$status == "TIME_LIMIT" && !is.null(sol$objval)) ~ 2L,
# (sol$status == "TIME_LIMIT" && is.null(sol$objval)) ~ 3L,
# sol$status == "SOLUTION_LIMIT" ~ 4L,
# TRUE ~ 999L
# )
status_chr <- as.character(sol$status %||% NA_character_)[1]
status_code <- if (identical(status_chr, "OPTIMAL")) {
0L
} else if (status_chr %in% c("INF_OR_UNBD", "INFEASIBLE", "UNBOUNDED")) {
1L
} else if (identical(status_chr, "TIME_LIMIT") && !is.null(sol$objval)) {
2L
} else if (identical(status_chr, "TIME_LIMIT") && is.null(sol$objval)) {
3L
} else if (identical(status_chr, "SOLUTION_LIMIT")) {
4L
} else {
999L
}
objval <- sol$objval %||% NA_real_
solvec <- sol$x %||% numeric(0)
gap <- sol$mipgap %||% NA_real_
runtime <- sol$runtime %||% NA_real_
} else if (solver == "cbc") {
# build row bounds from sense + rhs
row_lb <- rep(-Inf, length(model$rhs))
row_ub <- rep( Inf, length(model$rhs))
ii_le <- which(model$sense == "<=")
ii_ge <- which(model$sense == ">=")
ii_eq <- which(model$sense == "==" | model$sense == "=")
row_ub[ii_le] <- model$rhs[ii_le]
row_lb[ii_ge] <- model$rhs[ii_ge]
row_lb[ii_eq] <- model$rhs[ii_eq]
row_ub[ii_eq] <- model$rhs[ii_eq]
cbc_args <- list(
log = if (isTRUE(verbose)) "1" else "0",
ratio = as.character(gap_limit),
sec = as.character(time_limit),
timem = "elapsed"
)
if (mo_numeric) {
cbc_args <- c(cbc_args, list(primalTolerance = "1e-9",
integerTolerance = "1e-9", dualTolerance = "1e-9"))
}
if (!is.null(cores)) cbc_args$threads <- as.character(cores)
if (isTRUE(solution_limit)) cbc_args$maxso <- "1"
cbc_args <- utils::modifyList(cbc_args, solver_params_user)
if (mo_numeric) solve_args$effective_solver_params <- cbc_args
cbc_matrix <- .pa_cbc_complete_dimensions(
model$A, row_lb, row_ub,
model$bounds$lower$val, model$bounds$upper$val
)
rt <- system.time({
cbc_start <- initial_solution
if (!is.null(cbc_start)) cbc_start[model$vtype != "B"] <- NA_real_
sol_cbc <- rcbc::cbc_solve(
obj = model$obj,
mat = cbc_matrix$mat,
is_integer = ifelse(model$vtype == "B", TRUE, FALSE),
row_ub = cbc_matrix$row_ub,
row_lb = cbc_matrix$row_lb,
col_lb = model$bounds$lower$val,
col_ub = model$bounds$upper$val,
max = ifelse(model$modelsense == "min", FALSE, TRUE),
cbc_args = cbc_args,
initial_solution = cbc_start
)
})
runtime <- rt[[3]]
status_cbc <- rcbc::solution_status(sol_cbc)
status_code <- dplyr::case_when(
status_cbc == "optimal" ~ 0L,
status_cbc == "infeasible" ~ 1L,
(status_cbc == "timelimit" && !is.null(sol_cbc$objective_value)) ~ 2L,
(status_cbc == "timelimit" && is.null(sol_cbc$objective_value)) ~ 3L,
status_cbc == "solutionlimit" ~ 4L,
TRUE ~ 999L
)
objval <- sol_cbc$objective_value %||% NA_real_
solvec <- sol_cbc$column_solution %||% numeric(0)
gap <- if (isTRUE(status_code == 0L)) gap_limit else NA_real_
} else if (solver == "cplex") {
model$lb <- model$bounds$lower$val
model$ub <- model$bounds$upper$val
sense <- model$sense
sense[sense == ">="] <- "G"
sense[sense %in% c("==", "=")] <- "E"
sense[sense == "<="] <- "L"
# Avoid deprecated Matrix coercion inside Rcplex.
if (inherits(model$A, "sparseMatrix")) {
model$A <- methods::as(model$A, "CsparseMatrix")
}
params <- list(
trace = as.integer(verbose),
epgap = gap_limit,
tilim = time_limit
)
params <- utils::modifyList(
params,
solver_params_user
)
rt <- system.time({
sol_cplex <- Rcplex::Rcplex(
cvec = model$obj,
Amat = model$A,
bvec = model$rhs,
lb = model$lb,
ub = model$ub,
objsense = model$modelsense,
sense = sense,
vtype = model$vtype,
control = params
)
})
runtime <- unname(rt[["elapsed"]])
status_cplex <- as.integer(sol_cplex$status)[1]
status_raw <- as.character(status_cplex)
status_code <- if (status_cplex %in% c(1L, 101L, 102L)) {
0L
} else if (status_cplex %in% c(2L, 3L, 4L, 103L, 118L, 119L)) {
1L
} else if (status_cplex %in% c(107L, 111L, 113L, 131L)) {
2L
} else if (status_cplex %in% c(108L, 112L, 114L, 132L)) {
3L
} else if (status_cplex == 104L) {
4L
} else {
999L
}
objval <- sol_cplex$obj %||% NA_real_
solvec <- sol_cplex$xopt %||% numeric(0)
# Rcplex does not expose the final relative MIP gap directly.
# For strict optimality it is zero; for tolerance optimality,
# the accepted tolerance is the best available value.
gap <- if (status_cplex %in% c(1L, 101L)) {
0
} else if (status_cplex == 102L) {
gap_limit
} else {
NA_real_
}
} else if (solver == "symphony") {
max_flag <- ifelse(model$modelsense == "min", FALSE, TRUE)
verbosity <- as.integer(verbose) - 2
rt <- system.time({
sol_sym <- Rsymphony::Rsymphony_solve_LP(
obj = model$obj,
mat = model$A,
dir = model$sense,
rhs = model$rhs,
bounds = model$bounds,
types = model$vtype,
max = max_flag,
gap_limit = gap_limit,
time_limit = time_limit,
verbosity = verbosity,
first_feasible = solution_limit
)
})
runtime <- rt[[3]]
status_code <- dplyr::case_when(
sol_sym$status %in% c(0L, 231L) ~ 0L,
sol_sym$status %in% c(226L, 237L) ~ 1L,
sol_sym$status %in% c(235L, 228L) ~ 2L,
sol_sym$status == 232L ~ 4L,
TRUE ~ 999L
)
objval <- sol_sym$objval %||% NA_real_
solvec <- sol_sym$solution %||% numeric(0)
gap <- if (isTRUE(status_code == 0L)) gap_limit else NA_real_
} else {
stop("Internal error: unknown solver '", solver, "'.", call. = FALSE)
}
# Return the objective in its original units, including AUGMECON's original
# augmentation coefficient. Only the solver-facing copy was rescaled.
objval <- objval / objective_scale
# ------------------------------------------------------------
# Hard fail if solver returned no usable solution
# ------------------------------------------------------------
if (length(solvec) == 0L || all(is.na(solvec))) {
msg <- paste0(
"Solver returned an empty solution vector.\n",
"solver: ", solver, "\n",
"status_code: ", status_code, "\n",
"objval: ", as.character(objval), "\n",
"Possible causes: infeasible model, time limit before first feasible, or solver error.\n",
"Tip: try increasing time_limit, relaxing constraints, or inspect solver logs (if available)."
)
stop(msg, call. = FALSE)
}
# Ensure solution length is consistent with model offsets
n_pu_chk <- as.integer(model$n_pu %||% 0L)
n_x_chk <- as.integer(model$n_x %||% 0L)
n_z_chk <- as.integer(model$n_z %||% 0L)
w0_chk <- as.integer(model$w_offset %||% 0L)
x0_chk <- as.integer(model$x_offset %||% 0L)
z0_chk <- as.integer(model$z_offset %||% 0L)
needed_len <- max(
w0_chk + n_pu_chk,
x0_chk + n_x_chk,
z0_chk + n_z_chk,
0L
)
if (length(solvec) < needed_len) {
stop(
"Solver returned a solution vector of length ", length(solvec),
" but the model requires at least ", needed_len, " variables ",
"(based on offsets + variable counts). ",
"This indicates a mismatch between the built model and the decoded metadata.",
call. = FALSE
)
}
# ------------------------------------------------------------
# 2) Minimal decoding using offsets (0-based in C++; +1 in R)
# ------------------------------------------------------------
# n_pu <- as.integer(model$n_pu %||% 0L)
# n_x <- as.integer(model$n_x %||% 0L)
# n_z <- as.integer(model$n_z %||% 0L)
#
# w0 <- as.integer(model$w_offset %||% 0L)
# x0 <- as.integer(model$x_offset %||% 0L)
# z0 <- as.integer(model$z_offset %||% 0L)
#
# sol_monitoring <- if (n_pu > 0L && length(solvec) >= (w0 + n_pu)) {
# base::round(solvec[(w0 + 1L):(w0 + n_pu)])
# } else numeric(0)
#
# sol_actions <- if (n_x > 0L && length(solvec) >= (x0 + n_x)) {
# base::round(solvec[(x0 + 1L):(x0 + n_x)])
# } else numeric(0)
#
# sol_conservation <- if (n_z > 0L && length(solvec) >= (z0 + n_z)) {
# solvec[(z0 + 1L):(z0 + n_z)]
# } else numeric(0)
# ------------------------------------------------------------
# 3) Build human-readable tables (you implement this helper)
# ------------------------------------------------------------
has_feasible_solution <- status_code %in% c(0L, 2L, 4L)
if (!has_feasible_solution) {
stop(
"Solver did not return a feasible solution.\n",
"solver: ", solver, "\n",
"status_code: ", status_code, "\n",
"status: ", status_cbc %||% "unknown",
call. = FALSE
)
}
summary <- .pa_extract_solution_tables(x, solvec)
x$data$runtime_updates <- NULL
objs <- x$data$objectives %||% list()
alias_values <- NULL
if (is.list(objs) && length(objs) == 1L) {
alias_single <- names(objs)[1]
alias_values <- stats::setNames(objval, alias_single)
}
s <- pproto(
NULL, Solution,
problem = NULL,
solution = list(
objective = objval,
vector = solvec,
alias_values = alias_values
),
summary = summary,
diagnostics = list(
status_code = as.integer(status_code),
gap = gap,
runtime = runtime,
solver = solve_args$solver,
cores = solve_args$cores,
timelimit = solve_args$timelimit,
verbose = solve_args$verbose,
solution_limit = solve_args$solution_limit,
name_output_file = solve_args$name_output_file,
output_file = solve_args$output_file,
solver_args = solve_args
),
method = list(
type = "single"
),
meta = list()
)
s
}
.validate_split_effects <- function(tbl, context = "effects") {
if (!("benefit" %in% names(tbl)) || !("loss" %in% names(tbl))) {
stop("Internal error: .validate_split_effects() requires 'benefit' and 'loss' columns.", call. = FALSE)
}
tbl$benefit <- as.numeric(tbl$benefit)
tbl$loss <- as.numeric(tbl$loss)
#if (na_to_zero) {
tbl$benefit[is.na(tbl$benefit)] <- 0
tbl$loss[is.na(tbl$loss)] <- 0
#}
if (any(tbl$benefit < 0, na.rm = TRUE) || any(tbl$loss < 0, na.rm = TRUE)) {
stop(
context,
": 'benefit' and 'loss' must be non-negative.",
call. = FALSE
)
}
bad <- which(tbl$benefit > 0 & tbl$loss > 0)
if (length(bad) > 0) {
ex <- tbl[bad[1], intersect(c("pu", "action", "feature", "benefit", "loss"), names(tbl)), drop = FALSE]
msg <- paste0(
context,
": a single (pu, action, feature) effect cannot have both positive 'benefit' and positive 'loss'. ",
"This is checked after aggregation by (pu, action, feature), so the same triple cannot contain both gains and damages."
)
if (nrow(ex) == 1) {
msg <- paste0(
msg,
" Example offending row -> pu=", ex$pu,
", action='", ex$action,
"', feature=", ex$feature,
", benefit=", ex$benefit,
", loss=", ex$loss, "."
)
}
stop(msg, call. = FALSE)
}
tbl
}
.pa_model_is_current <- function(x) {
stopifnot(inherits(x, "Problem"))
has_ptr <- !is.null(x$data$model_ptr)
has_list <- !is.null(x$data$model_list) && is.list(x$data$model_list)
dirty <- isTRUE(x$data$meta$model_dirty)
isTRUE(has_ptr && has_list && !dirty)
}
.pa_compile_problem <- function(x, ...) {
.pa_build_model(x)
}
.pa_store_area_constraints <- function(x, area_df) {
stopifnot(inherits(x, "Problem"))
stopifnot(is.data.frame(area_df))
stopifnot(nrow(area_df) >= 1)
required_cols <- c(
"type", "sense", "value", "tolerance",
"unit", "area_col", "actions", "name"
)
miss <- setdiff(required_cols, names(area_df))
if (length(miss) > 0) {
stop(
"Missing required columns in `area_df`: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
if (any(area_df$type != "area")) {
stop("All rows in `area_df` must have `type = 'area'`.", call. = FALSE)
}
if (any(is.na(area_df$sense)) ||
any(!area_df$sense %in% c("min", "max", "equal"))) {
stop(
"`area_df$sense` must contain only 'min', 'max', or 'equal'.",
call. = FALSE
)
}
if (any(!is.finite(area_df$value)) || any(area_df$value < 0)) {
stop(
"`area_df$value` must contain only finite values >= 0.",
call. = FALSE
)
}
if (any(!is.finite(area_df$tolerance)) || any(area_df$tolerance < 0)) {
stop(
"`area_df$tolerance` must contain only finite values >= 0.",
call. = FALSE
)
}
if (any(is.na(area_df$unit)) ||
any(!area_df$unit %in% c("m2", "ha", "km2"))) {
stop(
"`area_df$unit` must contain only 'm2', 'ha', or 'km2'.",
call. = FALSE
)
}
if (any(is.na(area_df$name)) || any(!nzchar(area_df$name))) {
stop(
"`area_df$name` must contain only non-empty character strings.",
call. = FALSE
)
}
area_df$actions <- as.character(area_df$actions)
area_df$area_col <- as.character(area_df$area_col)
area_df$name <- as.character(area_df$name)
area_df$type <- as.character(area_df$type)
area_df$sense <- as.character(area_df$sense)
area_df$unit <- as.character(area_df$unit)
new_actions_key <- ifelse(is.na(area_df$actions), "__ALL__", area_df$actions)
new_key <- paste(new_actions_key, area_df$sense,
ifelse(is.na(area_df$area_col), "__DEFAULT__", area_df$area_col), sep = "||")
if (anyDuplicated(new_key)) {
dup <- unique(new_key[duplicated(new_key)])[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"Duplicated area constraints detected within `area_df` for ",
subset_label,
" and sense = '", sense_key, "'.",
call. = FALSE
)
}
cons <- x$data$constraints %||% list()
old <- cons$area
if (is.null(old)) {
cons$area <- area_df[, required_cols, drop = FALSE]
rownames(cons$area) <- NULL
x$data$constraints <- cons
return(x)
}
if (!is.data.frame(old)) {
stop(
"Stored area constraints must be a data.frame. Please rebuild the problem object.",
call. = FALSE
)
}
old_miss <- setdiff(required_cols, names(old))
if (length(old_miss) > 0) {
stop(
"Stored area constraints are malformed. Missing columns: ",
paste(old_miss, collapse = ", "),
".",
call. = FALSE
)
}
old$actions <- as.character(old$actions)
old$sense <- as.character(old$sense)
old_actions_key <- ifelse(is.na(old$actions), "__ALL__", old$actions)
old_key <- paste(old_actions_key, old$sense,
ifelse(is.na(old$area_col), "__DEFAULT__", old$area_col), sep = "||")
overlap <- intersect(old_key, new_key)
if (length(overlap) > 0) {
dup <- overlap[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"An area constraint already exists for the same subset of actions (",
subset_label,
") and sense = '", sense_key, "'.",
call. = FALSE
)
}
out <- rbind(
old[, required_cols, drop = FALSE],
area_df[, required_cols, drop = FALSE]
)
rownames(out) <- NULL
cons$area <- out
x$data$constraints <- cons
x
}
.pa_store_budget_constraints <- function(x, budget_df) {
stopifnot(inherits(x, "Problem"))
stopifnot(is.data.frame(budget_df))
stopifnot(nrow(budget_df) >= 1)
required_cols <- c(
"type", "sense", "value", "tolerance",
"actions", "include_pu_cost", "include_action_cost", "name"
)
miss <- setdiff(required_cols, names(budget_df))
if (length(miss) > 0) {
stop(
"Missing required columns in `budget_df`: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
if (any(budget_df$type != "budget")) {
stop("All rows in `budget_df` must have `type = 'budget'.", call. = FALSE)
}
if (any(is.na(budget_df$sense)) ||
any(!budget_df$sense %in% c("min", "max", "equal"))) {
stop(
"`budget_df$sense` must contain only 'min', 'max', or 'equal'.",
call. = FALSE
)
}
if (any(!is.finite(budget_df$value)) || any(budget_df$value < 0)) {
stop(
"`budget_df$value` must contain only finite values >= 0.",
call. = FALSE
)
}
if (any(!is.finite(budget_df$tolerance)) || any(budget_df$tolerance < 0)) {
stop(
"`budget_df$tolerance` must contain only finite values >= 0.",
call. = FALSE
)
}
if (!is.logical(budget_df$include_pu_cost) ||
any(is.na(budget_df$include_pu_cost))) {
stop(
"`budget_df$include_pu_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
if (!is.logical(budget_df$include_action_cost) ||
any(is.na(budget_df$include_action_cost))) {
stop(
"`budget_df$include_action_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
if (any(!budget_df$include_pu_cost & !budget_df$include_action_cost)) {
stop(
"Each row in `budget_df` must have at least one of ",
"`include_pu_cost` or `include_action_cost` set to TRUE.",
call. = FALSE
)
}
actions_chr <- as.character(budget_df$actions)
bad_action_pu_mix <- !is.na(actions_chr) & nzchar(actions_chr) & budget_df$include_pu_cost
if (any(bad_action_pu_mix)) {
stop(
"`include_pu_cost = TRUE` is only supported when `actions` is NA/NULL, ",
"because planning-unit costs are not action-specific.",
call. = FALSE
)
}
if (any(is.na(budget_df$name)) || any(!nzchar(budget_df$name))) {
stop(
"`budget_df$name` must contain only non-empty character strings.",
call. = FALSE
)
}
budget_df$type <- as.character(budget_df$type)
budget_df$sense <- as.character(budget_df$sense)
budget_df$actions <- actions_chr
budget_df$name <- as.character(budget_df$name)
new_actions_key <- ifelse(is.na(budget_df$actions), "__ALL__", budget_df$actions)
new_key <- paste(new_actions_key, budget_df$sense, budget_df$include_pu_cost,
budget_df$include_action_cost, sep = "||")
if (anyDuplicated(new_key)) {
dup <- unique(new_key[duplicated(new_key)])[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"Duplicated budget constraints detected within `budget_df` for ",
subset_label,
" and sense = '", sense_key, "'.",
call. = FALSE
)
}
cons <- x$data$constraints %||% list()
old <- cons$budget
if (is.null(old)) {
cons$budget <- budget_df[, required_cols, drop = FALSE]
rownames(cons$budget) <- NULL
x$data$constraints <- cons
return(x)
}
if (!is.data.frame(old)) {
stop(
"Stored budget constraints must be a data.frame. Please rebuild the problem object.",
call. = FALSE
)
}
old_miss <- setdiff(required_cols, names(old))
if (length(old_miss) > 0) {
stop(
"Stored budget constraints are malformed. Missing columns: ",
paste(old_miss, collapse = ", "),
".",
call. = FALSE
)
}
old$type <- as.character(old$type)
old$sense <- as.character(old$sense)
old$actions <- as.character(old$actions)
old$name <- as.character(old$name)
if (any(old$type != "budget")) {
stop(
"Stored budget constraints are malformed: `type` must be 'budget'.",
call. = FALSE
)
}
if (any(is.na(old$sense)) || any(!old$sense %in% c("min", "max", "equal"))) {
stop(
"Stored budget constraints are malformed: invalid values in `sense`.",
call. = FALSE
)
}
if (!is.logical(old$include_pu_cost) || any(is.na(old$include_pu_cost))) {
stop(
"Stored budget constraints are malformed: `include_pu_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
if (!is.logical(old$include_action_cost) || any(is.na(old$include_action_cost))) {
stop(
"Stored budget constraints are malformed: `include_action_cost` must contain only TRUE/FALSE values.",
call. = FALSE
)
}
old_bad_action_pu_mix <- !is.na(old$actions) & nzchar(old$actions) & old$include_pu_cost
if (any(old_bad_action_pu_mix)) {
stop(
"Stored budget constraints are malformed: action-specific rows cannot have `include_pu_cost = TRUE`.",
call. = FALSE
)
}
old_actions_key <- ifelse(is.na(old$actions), "__ALL__", old$actions)
old_key <- paste(old_actions_key, old$sense, old$include_pu_cost,
old$include_action_cost, sep = "||")
overlap <- intersect(old_key, new_key)
if (length(overlap) > 0) {
dup <- overlap[1]
parts <- strsplit(dup, "\\|\\|")[[1]]
act_key <- parts[1]
sense_key <- parts[2]
subset_label <- if (identical(act_key, "__ALL__")) {
"all actions"
} else {
paste0("actions = {", act_key, "}")
}
stop(
"A budget constraint already exists for the same subset of actions (",
subset_label,
") and sense = '", sense_key, "'.",
call. = FALSE
)
}
out <- rbind(
old[, required_cols, drop = FALSE],
budget_df[, required_cols, drop = FALSE]
)
rownames(out) <- NULL
cons$budget <- out
x$data$constraints <- cons
x
}
.pa_apply_group_area_constraints_if_present <- function(x) {
stopifnot(inherits(x, "Problem"))
specs <- x$data$constraints$group_area %||% NULL
if (is.null(specs) || nrow(specs) == 0L) {
return(x)
}
if (is.null(x$data$model_ptr)) {
stop(
"Model pointer is missing while applying group-area constraints.",
call. = FALSE
)
}
dist_groups <- x$data$dist_groups
if (is.null(dist_groups) ||
!is.data.frame(dist_groups) ||
nrow(dist_groups) == 0L) {
stop(
"Group-distribution data are missing or empty.",
call. = FALSE
)
}
x <- .pa_refresh_model_snapshot(x)
model_list <- x$data$model_list
x0 <- as.integer(model_list$x_offset)
da <- x$data$dist_actions_model
for (k in seq_len(nrow(specs))) {
spec <- specs[k, , drop = FALSE]
group_id <- spec$group
target <- as.numeric(spec$value)
relative <- isTRUE(spec$relative)
actions_txt <- spec$actions
dg <- dist_groups[
dist_groups$group == group_id,
,
drop = FALSE
]
if (nrow(dg) == 0L) {
stop(
"No group-distribution rows were found for group `",
group_id,
"`.",
call. = FALSE
)
}
available_amount <- sum(dg$amount)
rhs <- if (relative) {
target * available_amount
} else {
target
}
actions_txt <- as.character(actions_txt)[1]
use_all_actions <- (
length(actions_txt) == 0L ||
is.na(actions_txt) ||
!nzchar(trimws(actions_txt)) ||
identical(trimws(actions_txt), "NA")
)
if (use_all_actions) {
da_actions <- da
} else {
actions_chr <- strsplit(
actions_txt,
"\\|"
)[[1]]
actions_chr <- trimws(actions_chr)
actions_chr <- actions_chr[
!is.na(actions_chr) &
nzchar(actions_chr) &
actions_chr != "NA"
]
if (length(actions_chr) == 0L) {
da_actions <- da
} else {
action_subset <- .pa_resolve_action_subset(
x,
subset = actions_chr
)
da_actions <- da[
da$action %in% action_subset$id,
,
drop = FALSE
]
}
}
matched <- merge(
da_actions[
,
c("internal_pu", "internal_row"),
drop = FALSE
],
dg[
,
c("internal_pu", "amount"),
drop = FALSE
],
by = "internal_pu",
all = FALSE,
sort = FALSE
)
if (nrow(matched) == 0L) {
stop(
"No decision variables match group `",
group_id,
"` and the selected actions.",
call. = FALSE
)
}
var_index <- x0 +
as.integer(matched$internal_row) -
1L
coeff <- as.numeric(matched$amount)
cpp_sense <- switch(
spec$sense,
min = ">=",
max = "<=",
equal = "=="
)
x <- .pa_add_linear_constraint(
x = x,
var_index_0based = var_index,
coeff = coeff,
sense = cpp_sense,
rhs = rhs,
name = spec$name,
block_name = "group_area",
tag = as.character(group_id),
refresh_snapshot = FALSE
)
}
x
}
.pa_apply_budget_constraints_if_present <- function(x) {
stopifnot(inherits(x, "Problem"))
cons <- x$data$constraints %||% list()
if (length(cons) == 0L) return(x)
specs <- cons$budget %||% NULL
if (is.null(specs)) return(x)
if (is.null(x$data$model_ptr)) {
stop("Model pointer is missing while applying budget constraints.", call. = FALSE)
}
x <- .pa_refresh_model_snapshot(x)
ml <- x$data$model_list
if (is.null(ml)) {
stop("Model snapshot is missing while applying budget constraints.", call. = FALSE)
}
if (!is.data.frame(specs)) {
stop("Stored budget constraints must be a data.frame.", call. = FALSE)
}
required_cols <- c(
"type", "sense", "value", "tolerance",
"actions", "include_pu_cost", "include_action_cost", "name"
)
miss <- setdiff(required_cols, names(specs))
if (length(miss) > 0) {
stop(
"Stored budget constraints are malformed. Missing columns: ",
paste(miss, collapse = ", "),
".",
call. = FALSE
)
}
n_pu <- as.integer(ml$n_pu %||% 0L)
if (n_pu <= 0L) {
stop("Model has n_pu=0; cannot apply budget constraints.", call. = FALSE)
}
da <- x$data$dist_actions_model %||% NULL
if (is.null(da) || !is.data.frame(da) || nrow(da) == 0L) {
stop(
"Budget constraints require `x$data$dist_actions_model`.",
call. = FALSE
)
}
if (!("internal_row" %in% names(da))) {
stop(
"`dist_actions_model` must contain column `internal_row`.",
call. = FALSE
)
}
if (!("cost" %in% names(da))) {
stop(
"`dist_actions_model` must contain column `cost`.",
call. = FALSE
)
}
x0 <- as.integer(ml$x_offset %||% 0L)
w0 <- as.integer(ml$w_offset %||% 0L)
for (k in seq_len(nrow(specs))) {
spec <- specs[k, , drop = FALSE]
sense <- as.character(spec$sense)[1]
rhs <- as.numeric(spec$value)[1]
tol <- as.numeric(spec$tolerance)[1]
nm <- as.character(spec$name)[1]
actions_txt <- as.character(spec$actions)[1]
include_pu_cost <- isTRUE(spec$include_pu_cost[[1]])
include_action_cost <- isTRUE(spec$include_action_cost[[1]])
if (!sense %in% c("min", "max", "equal")) {
stop("Unknown budget constraint sense: ", sense, call. = FALSE)
}
if (!is.finite(rhs) || is.na(rhs) || rhs < 0) {
stop("Invalid budget constraint value in stored budget constraints.", call. = FALSE)
}
if (!is.finite(tol) || is.na(tol) || tol < 0) {
stop("Invalid budget constraint tolerance in stored budget constraints.", call. = FALSE)
}
if (is.na(nm) || !nzchar(nm)) {
stop("Stored budget constraint has invalid `name`.", call. = FALSE)
}
if (!include_pu_cost && !include_action_cost) {
stop(
"Stored budget constraint `", nm,
"` has both `include_pu_cost` and `include_action_cost` set to FALSE.",
call. = FALSE
)
}
var_index <- integer(0)
coeff <- numeric(0)
# ------------------------------------------------------------
# planning-unit cost component (only for global budget)
# ------------------------------------------------------------
if (include_pu_cost) {
if (!is.na(actions_txt) && nzchar(actions_txt)) {
stop(
"Stored budget constraint `", nm,
"` has `include_pu_cost = TRUE` with an action-specific subset, which is not supported.",
call. = FALSE
)
}
pu_cost <- .pa_get_cost_vec(x$data$pu)
if (length(pu_cost) != n_pu) {
stop(
"Planning-unit cost vector length (", length(pu_cost), ") != n_pu (", n_pu,
") while applying budget constraint `", nm, "`.",
call. = FALSE
)
}
j0_w <- w0 + (0:(n_pu - 1L))
var_index <- c(var_index, j0_w)
coeff <- c(coeff, as.numeric(pu_cost))
}
# ------------------------------------------------------------
# action cost component
# ------------------------------------------------------------
if (include_action_cost) {
keep <- rep(TRUE, nrow(da))
if (!is.na(actions_txt) && nzchar(actions_txt)) {
actions_chr <- strsplit(actions_txt, "\\|", fixed = FALSE)[[1]]
act_subset <- .pa_resolve_action_subset(x, subset = actions_chr)
if (!is.data.frame(act_subset) || nrow(act_subset) == 0L) {
stop(
"Stored budget constraint `", nm,
"` refers to an invalid or empty action subset.",
call. = FALSE
)
}
keep <- da$action %in% act_subset$id
}
if (!any(keep)) {
stop(
"Stored budget constraint `", nm,
"` does not match any rows in `dist_actions_model`.",
call. = FALSE
)
}
var_index_x <- x0 + (as.integer(da$internal_row[keep]) - 1L)
coeff_x <- as.numeric(da$cost[keep])
if (length(var_index_x) != length(coeff_x) || length(coeff_x) == 0L) {
stop(
"Failed to assemble action-cost coefficients for budget constraint `", nm, "`.",
call. = FALSE
)
}
var_index <- c(var_index, var_index_x)
coeff <- c(coeff, coeff_x)
}
if (length(var_index) != length(coeff) || length(coeff) == 0L) {
stop(
"Failed to assemble coefficients for budget constraint `", nm, "`.",
call. = FALSE
)
}
if (identical(sense, "min")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs,
name = nm
)
} else if (identical(sense, "max")) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs,
name = nm
)
} else if (identical(sense, "equal")) {
if (tol == 0) {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "==",
rhs = rhs,
name = nm
)
} else {
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = ">=",
rhs = rhs - tol,
name = paste0(nm, "_lower")
)
x <- .pa_add_linear_constraint(
x,
var_index_0based = var_index,
coeff = coeff,
sense = "<=",
rhs = rhs + tol,
name = paste0(nm, "_upper")
)
}
}
}
x
}
.pa_active_objective_alias <- function(x) {
objs <- x$data$objectives
if (is.null(objs) || !is.list(objs) || length(objs) == 0) {
return(NULL)
}
args <- x$data$model_args %||% list()
mtype <- args$model_type %||% NULL
oid <- args$objective_id %||% NULL
for (nm in names(objs)) {
ob <- objs[[nm]]
same_mtype <- !is.null(mtype) &&
identical(as.character(ob$model_type)[1], as.character(mtype)[1])
same_oid <- !is.null(oid) &&
identical(as.character(ob$objective_id)[1], as.character(oid)[1])
if (isTRUE(same_mtype) || isTRUE(same_oid)) {
return(ob$alias %||% nm)
}
}
NULL
}
.pa_feature_names_from_internal_ids <- function(x, ids) {
ids <- as.integer(ids)
f <- x$data$features
if (is.null(f) || !inherits(f, "data.frame") || nrow(f) == 0) {
return(as.character(ids))
}
label_col <- if ("name" %in% names(f)) {
"name"
} else if ("id" %in% names(f)) {
"id"
} else {
NULL
}
if (is.null(label_col) || !("internal_id" %in% names(f))) {
return(as.character(ids))
}
out <- as.character(f[[label_col]][match(ids, f$internal_id)])
out[is.na(out)] <- as.character(ids[is.na(out)])
out
}
.pa_action_names_from_internal_ids <- function(x, ids) {
ids <- as.integer(ids)
a <- x$data$actions
if (is.null(a) || !inherits(a, "data.frame") || nrow(a) == 0) {
return(as.character(ids))
}
label_col <- if ("name" %in% names(a)) {
"name"
} else if ("id" %in% names(a)) {
"id"
} else {
NULL
}
if (is.null(label_col) || !("internal_id" %in% names(a))) {
return(as.character(ids))
}
out <- as.character(a[[label_col]][match(ids, a$internal_id)])
out[is.na(out)] <- as.character(ids[is.na(out)])
out
}
#' Prepare an objective matrix for internal multi-objective operations
#'
#' @noRd
.pa_get_objective_matrix <- function(x,
objectives = NULL,
minimize = TRUE,
drop_na = TRUE,
minimum_objectives = 2L) {
if (!inherits(x, "SolutionSet")) {
stop("x must be a SolutionSet object.", call. = FALSE)
}
if (
length(minimum_objectives) != 1L ||
!is.numeric(minimum_objectives) ||
is.na(minimum_objectives) ||
!is.finite(minimum_objectives) ||
minimum_objectives < 1L ||
minimum_objectives != floor(minimum_objectives)
) {
stop(
"Internal error: `minimum_objectives` must be a positive integer.",
call. = FALSE
)
}
minimum_objectives <- as.integer(minimum_objectives)
vals <- .pa_get_objectives_internal(
x,
format = "wide"
)
if (!inherits(vals, "data.frame") || nrow(vals) == 0L) {
stop("No objective values are available.", call. = FALSE)
}
if (!("run_id" %in% names(vals))) {
stop("Objective table must contain a 'run_id' column.", call. = FALSE)
}
if (!("solution_id" %in% names(vals))) {
vals$solution_id <- NA_integer_
}
available <- setdiff(names(vals), c("run_id", "solution_id"))
if (length(available) == 0L) {
stop("No objective columns found.", call. = FALSE)
}
if (is.null(objectives)) {
objectives <- available
} else {
objectives <- as.character(objectives)
objectives <- objectives[!is.na(objectives) & nzchar(objectives)]
if (length(objectives) == 0L) {
stop("`objectives` must contain at least one objective name.", call. = FALSE)
}
bad <- setdiff(objectives, available)
if (length(bad) > 0L) {
stop(
"Unknown objective(s): ",
paste(bad, collapse = ", "),
". Available objectives are: ",
paste(available, collapse = ", "),
".",
call. = FALSE
)
}
}
if (length(objectives) < minimum_objectives) {
objective_word <- if (minimum_objectives == 1L) {
"one objective is"
} else if (minimum_objectives == 2L) {
"two objectives are"
} else {
paste0(minimum_objectives, " objectives are")
}
stop(
"At least ",
objective_word,
" required to evaluate dominance.",
call. = FALSE
)
}
mat <- as.matrix(vals[, objectives, drop = FALSE])
storage.mode(mat) <- "double"
if (isTRUE(drop_na)) {
ok <- stats::complete.cases(mat)
vals <- vals[ok, , drop = FALSE]
mat <- mat[ok, , drop = FALSE]
}
if (nrow(mat) == 0L) {
stop("No complete objective rows are available.", call. = FALSE)
}
specs <- get_objective_specs(x)
if (!all(c("objective", "sense") %in% names(specs))) {
stop(
"Objective specifications must contain 'objective' and 'sense' columns.",
call. = FALSE
)
}
sense <- stats::setNames(as.character(specs$sense), specs$objective)
sense <- sense[objectives]
if (anyNA(sense) || any(!nzchar(sense))) {
missing <- objectives[is.na(sense) | !nzchar(sense)]
stop(
"Missing optimization sense for objective(s): ",
paste(missing, collapse = ", "),
".",
call. = FALSE
)
}
if (!all(sense %in% c("min", "max"))) {
bad <- objectives[!sense %in% c("min", "max")]
stop(
"Invalid optimization sense for objective(s): ",
paste(bad, collapse = ", "),
". Expected 'min' or 'max'.",
call. = FALSE
)
}
if (isTRUE(minimize)) {
max_cols <- which(sense == "max")
if (length(max_cols) > 0L) {
mat[, max_cols] <- -mat[, max_cols, drop = FALSE]
}
}
row_ids <- vals$solution_id
missing_solution_id <- is.na(row_ids)
if (any(missing_solution_id)) {
row_ids[missing_solution_id] <- paste0("run_", vals$run_id[missing_solution_id])
}
rownames(mat) <- row_ids
list(
run_id = vals$run_id,
solution_id = vals$solution_id,
objectives = objectives,
sense = sense,
minimize = isTRUE(minimize),
matrix = mat
)
}
.pa_get_objectives_internal <- function(x,
format = c("wide", "long")) {
format <- match.arg(format)
runs <- x$solution$runs %||% NULL
if (is.null(runs) || !inherits(runs, "data.frame")) {
stop("No run table found in x$solution$runs.", call. = FALSE)
}
value_cols <- grep("^value_", names(runs), value = TRUE)
if (length(value_cols) == 0L) {
stop(
"No objective value columns found in the internal run table. ",
"Expected columns named 'value_<objective>'.",
call. = FALSE
)
}
if (!("run_id" %in% names(runs))) {
runs$run_id <- seq_len(nrow(runs))
}
runs$run_id <- as.integer(runs$run_id)
if (!("solution_id" %in% names(runs))) {
runs$solution_id <- NA_integer_
} else {
runs$solution_id <- suppressWarnings(as.integer(runs$solution_id))
}
objectives <- sub("^value_", "", value_cols)
if (identical(format, "wide")) {
out <- runs[, c("run_id", "solution_id", value_cols), drop = FALSE]
names(out) <- c("run_id", "solution_id", objectives)
rownames(out) <- NULL
return(out)
}
out <- do.call(
rbind,
lapply(seq_along(value_cols), function(i) {
data.frame(
run_id = runs$run_id,
solution_id = runs$solution_id,
objective = objectives[i],
value = as.numeric(runs[[value_cols[i]]]),
stringsAsFactors = FALSE
)
})
)
rownames(out) <- NULL
out
}
.pa_validate_positive_integer_ids <- function(
x,
argument = "id",
scalar = FALSE
) {
if (isTRUE(scalar) && length(x) != 1L) {
stop("`", argument, "` must be a single positive integer.", call. = FALSE)
}
if (length(x) == 0L) {
stop("`", argument, "` must contain at least one positive integer.", call. = FALSE)
}
if (!is.numeric(x) || is.logical(x)) {
stop("`", argument, "` must contain numeric positive integers.", call. = FALSE)
}
invalid_missing <- is.na(x)
present <- !is.na(x)
if (
any(invalid_missing) ||
any(!is.finite(x[present])) ||
any(x[present] < 1) ||
any(x[present] != floor(x[present])) ||
any(x[present] > .Machine$integer.max)
) {
stop("`", argument, "` must contain positive integers.", call. = FALSE)
}
out <- rep(NA_integer_, length(x))
out[present] <- as.integer(x[present])
out
}
.pa_as_int_id <- function(x, what = "id") {
if (is.factor(x)) {
x <- as.character(x)
}
if (is.character(x)) {
x <- trimws(x)
if (anyNA(x) || any(!nzchar(x))) {
stop("`", what, "` must not contain NA or empty values.", call. = FALSE)
}
ok <- grepl("^[-+]?[0-9]+$", x)
if (!all(ok)) {
bad <- unique(x[!ok])
stop(
"`", what, "` must contain integer-like ids. ",
"Character ids with non-numeric symbols are not currently supported. ",
"Problematic values: ",
paste(utils::head(bad, 20), collapse = ", "),
if (length(bad) > 20) " ..." else "",
call. = FALSE
)
}
out <- suppressWarnings(as.integer(x))
} else if (is.numeric(x) || is.integer(x)) {
if (anyNA(x) || any(!is.finite(x))) {
stop("`", what, "` must not contain NA or non-finite values.", call. = FALSE)
}
if (any(abs(x - round(x)) > .Machine$double.eps^0.5)) {
stop("`", what, "` must contain integer-like numeric values.", call. = FALSE)
}
out <- as.integer(round(x))
} else {
stop("`", what, "` must be integer-like.", call. = FALSE)
}
if (anyNA(out)) {
stop("`", what, "` contains values that cannot be converted to integer.", call. = FALSE)
}
out
}
Try the multiscape package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.