/
compile.R
203 lines (201 loc) · 5.97 KB
/
compile.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
#' @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
}