#' @include internal.R pproto.R Collection-proto.R
NULL
#' @export
methods::setOldClass("ConservationProblem")
#' Conservation problem class
#'
#' This class is used to represent conservation planning problems. A
#' conservation planning problem has spatially explicit planning units.
#' A prioritization involves making a decision on each planning unit (eg. is
#' the planning unit going to be turned into a protected area?). Each
#' planning unit is associated with a cost that represents the cost incurred
#' by applying the decision to the planning unit. The problem also has a set
#' of representation targets for each feature. Further, it also has
#' constraints used to ensure that the solution meets additional
#' objectives (eg. certain areas are locked into the solution). Finally,
#' a conservation planning problem--unlike an optimization problem--also
#' requires a method to solve the problem. \strong{This class represents a
#' planning problem, to actually build and then solve a planning problem,
#' use the \code{\link{problem}} function. Only experts should use this
#' class directly.}
#'
#' @section Fields:
#' \describe{
#'
#' \item{$data}{\code{list} object containing data.}
#'
#' \item{$objective}{\code{\link{Objective-class}} object used to represent how
#' the targets relate to the solution.}
#'
#' \item{$decision}{\code{\link{Decision-class}} object used to represent the
#' type of decision made on planning units.}
#'
#' \item{$targets}{\code{\link{Target-class}} object used to represent
#' representation targets for features.}
#'
#' \item{$penalties}{\code{\link{Collection-class}} object used to represent
#' additional \code{\link{penalties}} that the problem is subject to.}
#'
#' \item{$constraints}{\code{\link{Collection-class}} object used to represent
#' additional \code{\link{constraints}} that the problem is subject to.}
#'
#' \item{$solver}{\code{\link{Solver-class}} object used to solve the problem.}
#'
#' }
#'
#' @section Usage:
#'
#' \code{x$print()}
#'
#' \code{x$show()}
#'
#' \code{x$repr()}
#'
#' \code{x$get_data(name)}
#'
#' \code{x$set_data(name, value)}
#'
#' \code{x$number_of_total_units()}
#'
#' \code{x$number_of_planning_units()}
#'
#' \code{x$planning_unit_costs()}
#'
#' \code{x$number_of_features()}
#'
#' \code{x$feature_names()}
#'
#' \code{x$feature_abundances_in_planning_units()}
#'
#' \code{x$feature_targets()}
#'
#' \code{x$add_objective(obj)}
#'
#' \code{x$add_decision(dec)}
#'
#' \code{x$add_solver(sol)}
#'
#' \code{x$add_constraint(con)}
#'
#' \code{x$add_targets(targ)}
#'
#' \code{x$get_constraint_parameter(id)}
#'
#' \code{x$set_constraint_parameter(id, value)}
#'
#' \code{x$render_constraint_parameter(id)}
#'
#' \code{x$render_all_constraint_parameters()}
#'
#' \code{x$get_objective_parameter(id)}
#'
#' \code{x$set_objective_parameter(id, value)}
#'
#' \code{x$render_objective_parameter(id)}
#'
#' \code{x$render_all_objective_parameters()}
#'
#' \code{x$get_solver_parameter(id)}
#'
#' \code{x$set_solver_parameter(id, value)}
#'
#' \code{x$render_solver_parameter(id)}
#'
#' \code{x$render_all_solver_parameters()}
#'
#' @section Arguments:
#'
#' \describe{
#'
#' \item{name}{\code{character} name for object.}
#'
#' \item{value}{an object.}
#'
#' \item{obj}{\code{\link{Objective-class}} object.}
#'
#' \item{dec}{\code{\link{Decision-class}} object.}
#'
#' \item{con}{\code{\link{Constraint-class}} object.}
#'
#' \item{sol}{\code{\link{Solver-class}} object.}
#'
#' \item{targ}{\code{\link{Target-class}} object.}
#'
#' \item{cost}{\code{\link[raster]{RasterLayer-class}},
#' \code{\link[sp]{SpatialPolygonsDataFrame-class}}, or
#' \code{\link[sp]{SpatialLinesDataFrame-class}} object showing spatial
#' representation of the planning units and their cost.}
#'
#' \item{features}{\code{\link[raster]{RasterStack-class}} object showing
#' distribution of features.}
#'
#' \item{id}{\code{Id} object that refers to a specific parameter.}
#'
#' \item{value}{object that the parameter value should become.}
#'
#' }
#'
#' @section Details:
#' \describe{
#' \item{print}{print the object.}
#'
#' \item{show}{show the object.}
#'
#' \item{repr}{return \code{character} representation of the object.}
#'
#' \item{get_data}{return an object stored in the \code{data} field with
#' the corresponding \code{name}. If the object is not present in the
#' \code{data} field, a \code{waiver} object is returned.}
#'
#' \item{set_data}{store an object stored in the \code{data} field with
#' the corresponding name. If an object with that name already
#' exists then the object is overwritten.}
#'
#' \item{number_of_planning_units}{\code{integer} number of planning units.}
#'
#' \item{number_of_total_units}{\code{integer} number of units in the cost
#' data including units that have NA values for cost.}
#'
#' \item{planning_unit_costs}{\code{numeric} costs of each planning unit.}
#'
#' \item{number_of_features}{\code{integer} number of features.}
#'
#' \item{feature_names}{\code{character} names of features in problem.}
#'
#' \item{feature_abundances_in_planning_units}{\code{numeric} get total
#' abundance of each feature in all the planning units.}
#'
#' \item{feature_targets}{\code{numeric} targets for each feature.}
#'
#' \item{add_objective}{return a new \code{\link{ConservationProblem-class}}
#' with the objective added to it.}
#'
#' \item{add_decision}{return a new \code{\link{ConservationProblem-class}}
#' object with the decision added to it.}
#'
#' \item{add_solver}{return a new \code{\link{ConservationProblem-class}} object
#' with the solver added to it.}
#'
#' \item{add_constraint}{return a new \code{\link{ConservationProblem-class}}
#' object with the constraint added to it.}
#'
#' \item{add_targets}{return a copy with the targets to the problem.}
#'
#' \item{get_constraint_parameter}{get the value of a parameter (specified by
#' argument \code{id}) used in one of the constraints in the object.}
#'
#' \item{set_constraint_parameter}{set the value of a parameter (specified by
#' argument \code{id}) used in one of the constraints in the object to
#' \code{value}.}
#'
#' \item{render_constraint_parameter}{generate a \emph{shiny} widget to modify
#' the value of a parameter (specified by argument \code{id}).}
#'
#' \item{render_all_constraint_parameters}{generate a \emph{shiny} \code{div}
#' containing all the parameters" widgets.}
#'
#' \item{get_objective_parameter}{get the value of a parameter (specified by
#' argument \code{id}) used in one of the objectives in the object.}
#'
#' \item{set_objective_parameter}{set the value of a parameter (specified by
#' argument \code{id}) used in one of the objectives in the object to
#' \code{value}.}
#'
#' \item{render_objective_parameter}{generate a \emph{shiny} widget to modify
#' the value of a parameter (specified by argument \code{id}).}
#'
#' \item{render_all_objective_parameters}{generate a \emph{shiny} \code{div}
#' containing all the parameters" widgets.}
#'
#' \item{get_solver_parameter}{get the value of a parameter (specified by
#' argument \code{id}) used in one of the solvers in the object.}
#'
#' \item{set_solver_parameter}{set the value of a parameter (specified by
#' argument \code{id}) used in one of the solvers in the object to
#' \code{value}.}
#'
#' \item{render_solver_parameter}{generate a \emph{shiny} widget to modify the
#' the value of a parameter (specified by argument \code{id}).}
#'
#' \item{render_all_solver_parameters}{generate a \emph{shiny} \code{div}
#' containing all the parameters" widgets.}
#'
#' }
#' @name ConservationProblem-class
#'
#' @aliases ConservationProblem
NULL
#' @export
ConservationProblem <- pproto(
"ConservationProblem",
data = list(),
objective = waiver(),
decision = waiver(),
targets = waiver(),
constraints = pproto(NULL, Collection),
penalties = pproto(NULL, Collection),
solver = waiver(),
print = function(self) {
r <- sapply(list(self$objective, self$targets), function(x) {
if (is.Waiver(x))
return("none specified")
return(x$repr())
})
d <- sapply(list(self$solver, self$decision), function(x) {
if (is.Waiver(x))
return("default")
return(x$repr())
})
cs <- round(range(self$planning_unit_costs()), 5)
message(paste0("Conservation Problem",
"\n planning units: ", class(self$data$cost)[1], " (",
self$number_of_planning_units(), " units)",
"\n cost: min: ", cs[1], ", max: ", cs[2],
"\n features: ", paste(self$feature_names(), collapse = ", "),
"\n objective: ", r[1],
"\n targets: ", r[2],
"\n decision: ", d[2],
"\n constraints: ", self$constraints$repr(),
"\n penalties: ", self$penalties$repr(),
"\n solver: ", d[1]))
},
show = function(self) {
self$print()
},
repr = function(self) {
"ConservationProblem object"
},
get_data = function(self, x) {
assertthat::assert_that(assertthat::is.string(x))
if (!x %in% names(self$data))
return(waiver())
return(self$data[[x]])
},
set_data = function(self, x, value) {
assertthat::assert_that(assertthat::is.string(x))
self$data[[x]] <- value
invisible()
},
number_of_planning_units = function(self) {
if (inherits(self$data$cost, "Raster")) {
return(raster::cellStats(raster::Which(!is.na(self$data$cost)), "sum"))
} else if (inherits(self$data$cost, c("data.frame", "Spatial"))) {
return(nrow(self$data$cost))
} else {
stop("cost is of unknown class")
}
},
number_of_total_units = function(self) {
if (inherits(self$data$cost, "Raster")) {
return(raster::ncell(self$data$cost))
} else if (inherits(self$data$cost, c("data.frame", "Spatial"))) {
return(nrow(self$data$cost))
} else {
stop("cost is of unknown class")
}
},
planning_unit_costs = function(self) {
if (inherits(self$data$cost, "Raster")) {
return(self$data$cost[raster::Which(!is.na(self$data$cost))])
} else if (inherits(self$data$cost, c("data.frame",
"SpatialPolygonsDataFrame", "SpatialLinesDataFrame",
"SpatialPointsDataFrame"))) {
return(self$data$cost[[self$data$cost_column]])
} else {
stop("cost is of unknown class")
}
},
number_of_features = function(self) {
if (inherits(self$data$features, "Raster")) {
return(raster::nlayers(self$data$features))
} else if (inherits(self$data$features, "data.frame")) {
return(nrow(self$data$features))
} else {
stop("feature data is of an unrecognized class")
}
},
feature_names = function(self) {
if (inherits(self$data$features, "Raster")) {
return(names(self$data$features))
} else if (inherits(self$data$features, "data.frame")) {
return(as.character(self$data$features$name))
} else {
stop("feature data is of an unrecognized class")
}
},
feature_abundances_in_planning_units = function(self) {
Matrix::rowSums(self$data$rij_matrix)
},
feature_targets = function(self) {
if (is.Waiver(self$targets))
stop("problem is missing targets")
self$targets$output()
},
add_solver = function(self, x) {
assertthat::assert_that(inherits(x, "Solver"))
if (!is.Waiver(self$solver))
warning("overwriting previously defined solver")
pproto(NULL, self, solver = x)
},
add_targets = function(self, x) {
assertthat::assert_that(inherits(x, "Target"))
if (!is.Waiver(self$targets))
warning("overwriting previously defined targets")
pproto(NULL, self, targets = x)
},
add_objective = function(self, x) {
assertthat::assert_that(inherits(x, "Objective"))
if (!is.Waiver(self$objective))
warning("overwriting previously defined objective")
pproto(NULL, self, objective = x)
},
add_decision = function(self, x) {
assertthat::assert_that(inherits(x, "Decision"))
if (!is.Waiver(self$decision))
warning("overwriting previously defined decision")
pproto(NULL, self, decision = x)
},
add_constraint = function(self, x) {
assertthat::assert_that(inherits(x, "Constraint"))
p <- pproto(NULL, self)
p$constraints$add(x)
return(p)
},
add_penalty = function(self, x) {
assertthat::assert_that(inherits(x, "Penalty"))
p <- pproto(NULL, self)
p$penalties$add(x)
return(p)
},
get_constraint_parameter = function(self, id) {
self$constraints$get_parameter(id)
},
set_constraint_parameter = function(self, id, value) {
self$constraints$set_parameter(id, value)
},
render_constraint_parameter = function(self, id) {
self$constraints$render_parameter(id)
},
render_all_constraint_parameters = function(self) {
self$constraints$render_all_parameter()
},
get_objective_parameter = function(self, id) {
self$objective$get_parameter(id)
},
set_objective_parameter = function(self, id, value) {
self$objective$set_parameter(id, value)
},
render_objective_parameter = function(self, id) {
self$objective$render_parameter(id)
},
render_all_objective_parameters = function(self) {
self$objective$render_all_parameter()
},
get_solver_parameter = function(self, id) {
self$solver$get_parameter(id)
},
set_solver_parameter = function(self, id, value) {
self$solver$set_parameter(id, value)
},
render_solver_parameter = function(self, id) {
self$solver$render_parameter(id)
},
render_all_solver_parameters = function(self) {
self$solver$render_all_parameter()
},
get_penalty_parameter = function(self, id) {
self$penalty$get_parameter(id)
},
set_penalty_parameter = function(self, id, value) {
self$penalty$set_parameter(id, value)
},
render_penalty_parameter = function(self, id) {
self$penalty$render_parameter(id)
},
render_all_penalty_parameters = function(self) {
self$penalty$render_all_parameter()
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.