Nothing
#' @include internal.R pproto.R ProjectProblem-proto.R MiscParameter-proto.R tbl_df.R
NULL
#' Add manual targets
#'
#' Set targets for a project prioritization [problem()] by manually
#' specifying all the required information for each target. This function
#' is useful because it can be used to customize all aspects of a target. For
#' most cases, targets can be specified using the
#' [add_absolute_targets()] and [add_relative_targets()]
#' functions. However, this function can be used to mix absolute and
#' relative targets for different features.
#'
#' @param x [ProjectProblem-class] object.
#'
#' @param targets `data.frame` or [tibble::tibble()] object. See
#' the Details section for more information.
#'
#' @details Targets are used to specify the minimum probability of persistence
#' for each feature in solutions. For minimum set objectives
#' (i.e. [add_min_set_objective()], these targets
#' specify the minimum probability of persistence required for each species
#' in the solution. And for budget constrained objectives that use targets
#' (i.e. [add_max_targets_met_objective()]), these targets
#' specify the minimum threshold probability of persistence that needs to be
#' achieved to count the benefits for conserving these species.
#' Please note that attempting to solve problems with objectives that require
#' targets without specifying targets will throw an error.
#'
#' The `targets` argument should contain the following columns:
#'
#' \describe{
#'
#' \item{`"feature"`}{`character` name of features in argument
#' to `x`.}
#'
#' \item{`"type"`}{`character` describing the type of target.
#' Acceptable values include `"absolute"` and `"relative"`.
#' These values correspond to [add_absolute_targets()],
#' and [add_relative_targets()] respectively.}
#'
#' \item{`"sense"`}{`character` sense of the target. The
#' only acceptable value currently supported is: `">="`. This field
#' (column) is optional and if it is missing then target senses will
#' default to `">="` values.}
#'
#' \item{`"target"`}{`numeric` target threshold.}
#'
#' }
#'
#' @return [ProjectProblem-class] object with the targets added
#' to it.
#'
#' @inherit add_absolute_targets seealso return
#'
#' @examples
#' # load data
#' data(sim_projects, sim_features, sim_actions)
#'
#'
#' # create data frame with targets
#' targets <- data.frame(feature = sim_features$name,
#' type = "absolute",
#' target = 0.1)
#'
#' # print targets
#' print(targets)
#'
#' # build problem with minimum set objective and targets that require each
#' # feature to have a 30% chance of persisting into the future
#' p <- problem(sim_projects, sim_actions, sim_features,
#' "name", "success", "name", "cost", "name") %>%
#' add_min_set_objective() %>%
#' add_manual_targets(targets) %>%
#' add_binary_decisions()
#'
#' # print problem
#' print(p)
#'
#' \dontrun{
#' # solve problem
#' s <- solve(p)
#'
#' # print solution
#' print(s)
#' }
#' @aliases add_manual_targets-method add_manual_targets,ProjectProblem,data.frame-method add_manual_targets,ProjectProblem,tbl_df-method
#'
#' @name add_manual_targets
#'
#' @docType methods
NULL
#' @name add_manual_targets
#' @rdname add_manual_targets
#' @exportMethod add_manual_targets
#' @export
methods::setGeneric(
"add_manual_targets",
signature = methods::signature("x", "targets"),
function(x, targets) standardGeneric("add_manual_targets"))
#' @name add_manual_targets
#' @rdname add_manual_targets
#' @usage \S4method{add_manual_targets}{ProjectProblem,data.frame}(x, targets)
methods::setMethod(
"add_manual_targets",
methods::signature("ProjectProblem", "data.frame"),
function(x, targets) {
add_manual_targets(x, tibble::as_tibble(targets))
})
#' @name add_manual_targets
#' @rdname add_manual_targets
#' @usage \S4method{add_manual_targets}{ProjectProblem,tbl_df}(x, targets)
methods::setMethod(
"add_manual_targets",
methods::signature("ProjectProblem", "tbl_df"),
function(x, targets) {
# assert that arguments are valid
assertthat::assert_that(inherits(x, "ProjectProblem"))
validate_targets <- function(targets) {
assertthat::assert_that(
inherits(targets, "tbl_df"),
nrow(targets) > 0, ncol(targets) > 0,
assertthat::has_name(targets, "feature"),
assertthat::has_name(targets, "target"),
assertthat::has_name(targets, "type"),
all(names(targets) %in% c("feature", "type", "sense", "target")),
is.character(targets$feature) || is.factor(targets$feature),
all(as.character(targets$feature) %in% feature_names(x)),
is.numeric(targets$target), all(is.finite(targets$target)),
is.character(targets$type) || is.factor(targets$type),
all(targets$type %in% c("absolute", "relative")),
min(targets$target) >= 0,
max(targets$target) <= 1)
if (assertthat::has_name(targets, "sense"))
assertthat::assert_that(
is.character(targets$sense) || is.factor(targets$sense),
all(as.character(targets$sense) %in% c(">=")))
return(TRUE)
}
validate_targets(targets)
# define function to validate changes to the targets object
vfun <- function(x) !inherits(try(validate_targets(x), silent = TRUE),
"try-error")
# define function to render targets object
rfun <- function(x)
utils::getFromNamespace("rHandsontableOutput", "rhandsontable")(x)
# add targets to problem
x$add_targets(pproto(
"ManualTargets",
Target,
name = "Targets",
data = list(max_persistences = apply(x$epf_matrix(), 2, max),
feature_names = x$feature_names()),
parameters = parameters(misc_parameter("Targets", targets, vfun, rfun)),
repr = function(self) {
targets <- self$parameters$get("Targets")
if (all(as.character(targets$type) == "relative")) {
out <- "Relative"
} else if (all(as.character(targets$type) == "absolute")) {
out <- "Absolute"
} else {
out <- "Mixed"
}
out <- paste0(out, " targets [targets (min: ", min(targets$target),
", max: ", max(targets$target), ")]")
return(out)
},
output = function(self) {
# get data
targets <- self$parameters$get("Targets")
max_persistences <- self$data$max_persistences
feature_names <- self$data$feature_names
# add sense column if missing
if (!assertthat::has_name(targets, "sense"))
targets$sense <- ">="
targets$sense <- as.character(targets$sense)
# add targets for missing features
# these targets are -1 so they should always be met
missing_features <- setdiff(feature_names,
as.character(targets$feature))
if (length(missing_features) > 0) {
targets <- rbind(targets, tibble::tibble(feature = missing_features,
type = "absolute",
sense = ">=", target = -1))
targets <- tibble::as_tibble(targets)
}
# convert feature names to indices
targets$feature <- match(targets$feature, feature_names)
# add compute relative targets as absolute targets
targets$value <- as.numeric(targets$target)
relative_rows <- which(targets$type == "relative")
for (i in seq_along(relative_rows)) {
feature_id <- targets$feature[[relative_rows[[i]]]]
targets$value[relative_rows[i]] <- max_persistences[feature_id] *
targets$target[relative_rows[i]]
}
# return tibble
return(targets[, c("feature", "sense", "value")])
}))
})
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.