Nothing
#' @include internal.R ConservationProblem-class.R OptimizationProblem-class.R
NULL
#' Compile a problem
#'
#' Compile a conservation planning problem into an
#' mixed integer linear programming problem.
#'
#' @param x [problem()] object.
#'
#' @param compressed_formulation `logical` should the conservation problem
#' compiled into a compressed version of a planning problem?
#' If `TRUE` then the problem is expressed using the compressed
#' formulation. If `FALSE` then the problem is expressed using the
#' expanded formulation. If `NA`, then the compressed is used unless one
#' of the constraints requires the expanded formulation. This argument
#' defaults to `NA`.
#'
#' @param ... not used.
#'
#' @details This function might be useful for those interested in understanding
#' how their conservation planning [problem()] is expressed
#' as a mathematical problem. However, if the problem just needs to
#' be solved, then the [solve()] function should just be used.
#'
#' **Please note that in nearly all cases, the default argument to
#' `compressed_formulation` should be used**. The only situation where
#' manually
#' setting the argument to `formulation` is desirable is during testing.
#' Manually setting the argument to `formulation` will at best
#' have no effect on the problem. At worst, it may result in
#' an error, a misspecified problem, or unnecessarily long
#' solve times.
#'
#' @return A [optimization_problem()] object.
#'
#' @examples
#' \dontrun{
#' # load data
#' sim_pu_raster <- get_sim_pu_raster()
#' sim_features <- get_sim_features()
#'
#' # build minimal conservation problem
#' p <-
#' problem(sim_pu_raster, sim_features) %>%
#' add_min_set_objective() %>%
#' add_relative_targets(0.1)
#'
#' # compile the conservation problem into an optimization problem
#' o <- compile(p)
#'
#' # print the optimization problem
#' print(o)
#' }
#' @export
compile <- function(x, ...) UseMethod("compile")
#' @rdname compile
#' @export
compile.ConservationProblem <- function(x, compressed_formulation = NA, ...) {
# assert arguments are valid
assert_required(x)
assert_required(compressed_formulation)
assert(
is_conservation_problem(x),
assertthat::is.flag(compressed_formulation)
)
assert_dots_empty()
# sanity checks
targets_not_supported <- c(
"MaximumUtilityObjective",
"MaximumCoverageObjective"
)
if (
inherits(x$objective, targets_not_supported) &&
!is.Waiver(x$targets)
) {
cli_warning(
c(
"Targets specified for the problem will be ignored.",
"i" = "If the targets are important, use a different objective."
)
)
}
# replace waivers with defaults
if (is.Waiver(x$objective)) {
cli::cli_abort(
"{.fn problem} must have an objective.",
"i" = paste(
"see {.topic prioritizr::objectives} for guidance on selecting",
"an objective."
)
)
}
if (
is.Waiver(x$targets) &&
!inherits(
x$objective,
c("MaximumUtilityObjective", "MaximumCoverageObjective"))
) {
cli::cli_abort(
"{.fn problem} must have targets.",
"i" =
"see {.topic prioritizr::targets} for guidance on selecting targets."
)
}
# add defaults if needed
## this shouldn't really be needed because the
# default functions are now applied when the problem() is created
# nocov start
if (is.Waiver(x$decisions))
x <- suppressWarnings(add_binary_decisions(x))
if (is.Waiver(x$solver))
x <- suppressWarnings(add_default_solver(x))
if (is.Waiver(x$portfolio))
x <- suppressWarnings(add_shuffle_portfolio(x, 1))
# nocov end
# initialize optimization problems
op <- optimization_problem()
# determine if expanded formulation is required
if (is.na(compressed_formulation)) {
compressed_formulation <- all(
vapply(
x$constraints,
FUN.VALUE = logical(1),
function(i) i$compressed_formulation
)
)
}
# generate targets
if (is.Waiver(x$targets)) {
# if objective doesn't actually use targets, create a "fake" targets tibble
# to initialize rij matrix
targets <- tibble::as_tibble(
expand.grid(
feature = seq_along(x$feature_names()),
zone = seq_along(x$zone_names()),
sense = "?",
value = 0
)
)
targets$zone <- as.list(targets$zone)
} else {
# generate "real" targets
targets <- x$feature_targets()
}
# add rij data to optimization problem
rcpp_add_rij_data(
op$ptr, x$get_data("rij_matrix"), as.list(targets), compressed_formulation
)
# add decision types to optimization problem
x$decisions$calculate(x)
x$decisions$apply(op)
# add objective to optimization problem
x$objective$calculate(x)
x$objective$apply(op, x)
# add constraints for zones
if ((x$number_of_zones() > 1)) {
# detect if mandatory allocation constraints should be applied
if (length(x$constraints) == 0) {
apply_mandatory <- FALSE
} else {
apply_mandatory <- any(
vapply(
x$constraints, inherits, logical(1), "MandatoryAllocationConstraint"
)
)
}
# set constraint type
ct <- ifelse(apply_mandatory, "=", "<=")
# apply constraints
rcpp_add_zones_constraints(op$ptr, ct)
}
# add penalties to optimization problem
for (i in seq_along(x$penalties)) {
## run sanity check
if (
inherits(x$penalties[[i]], "FeatureWeights") &&
inherits(
x$objective,
c("MinimumSetObjective", "MinimumLargestShortfallObjective")
)
) {
cli_warning(
c(
"Weights specified for the problem will be ignored.",
"i" = "If the weights are important, use a different objective."
)
)
next()
}
## apply penalty if it makes sense to do so
x$penalties[[i]]$calculate(x)
x$penalties[[i]]$apply(op, x)
}
# add constraints to optimization problem
for (i in seq_along(x$constraints)) {
x$constraints[[i]]$calculate(x)
x$constraints[[i]]$apply(op, x)
}
# return problem object
op
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.