#' @include internal.R
NULL
#' Solution statistics
#'
#' Calculate statistics describing a solution to a project prioritization
#' [problem()].
#'
#' @param x project prioritization [problem()].
#'
#' @param solution [base::data.frame()] or
#' [tibble::tibble()] table containing the solutions. Here,
#' rows correspond to different solutions and columns correspond to
#' different actions. Each column in the argument to `solution` should
#' be named according to a different action in `x`.
#' Cell values indicate if an action is funded in a given solution or not,
#' and should be either zero or one. Arguments to `solution` can
#' contain additional columns, and they will be ignored.
#'
#' @return A [tibble::tibble()] table containing the following
#' columns:
#'
#' \describe{
#'
#' \item{`"cost"`}{`numeric` cost of each solution.}
#'
#' \item{`"obj"`}{`numeric` objective value for each solution.
#' This is calculated using the objective function defined for the
#' argument to `x`.}
#'
#' \item{`x$project_names()`}{`numeric` column for each
#' project indicating if it was completely funded (with a value of 1)
#' or not (with a value of 0).}
#'
#' \item{`x$feature_names()`}{`numeric` column for each
#' feature indicating the probability that it will persist into
#' the future given each solution.}
#'
#' }
#'
#' @seealso [objectives], [replacement_costs()],
#' [project_cost_effectiveness()].
#'
#' @examples
#' # load data
#' data(sim_projects, sim_features, sim_actions)
#'
#' # print project data
#' print(sim_projects)
#'
#' # print action data
#' print(sim_features)
#'
#' # print feature data
#' print(sim_actions)
#'
#' # build problem
#' p <- problem(sim_projects, sim_actions, sim_features,
#' "name", "success", "name", "cost", "name") %>%
#' add_max_richness_objective(budget = 400) %>%
#' add_feature_weights("weight") %>%
#' add_binary_decisions()
#'
#' # print problem
#' print(p)
#'
#' # create a table with some solutions
#' solutions <- data.frame(F1_action = c(0, 1, 1),
#' F2_action = c(0, 1, 0),
#' F3_action = c(0, 1, 1),
#' F4_action = c(0, 1, 0),
#' F5_action = c(0, 1, 1),
#' baseline_action = c(1, 1, 1))
#'
#' # print the solutions
#' # the first solution only has the baseline action funded
#' # the second solution has every action funded
#' # the third solution has only some actions funded
#' print(solutions)
#'
#' # calculate statistics
#' solution_statistics(p, solutions)
#' @export
solution_statistics <- function(x, solution) {
# assert arguments are valid
assertthat::assert_that(inherits(x, "ProjectProblem"),
inherits(solution, "data.frame"),
all(assertthat::has_name(solution, x$action_names())))
assertthat::assert_that(!is.Waiver(x$objective),
msg = "argument to x does not have an objective specified.")
if (!inherits(solution, "tbl_df"))
solution <- tibble::as_tibble(solution)
# calculate cost and objective values
out <- tibble::tibble(
cost = rowSums(as.matrix(solution[, x$action_names()]) *
matrix(x$action_costs(), byrow = TRUE,
ncol = x$number_of_actions(),
nrow = nrow(solution))),
obj = x$objective$evaluate(x, solution[, x$action_names()]))
# add in columns indicating if each project is funded or not
out <- tibble::as_tibble(cbind(out, stats::setNames(as.data.frame(
rcpp_funded_projects(
x$pa_matrix(),
as_Matrix(as.matrix(solution[, x$action_names()]), "dgCMatrix"))),
x$project_names())))
# add in columns for feature persistences
out <- tibble::as_tibble(cbind(out, stats::setNames(as.data.frame(
rcpp_expected_persistences(
x$pa_matrix(), x$epf_matrix(),
as_Matrix(diag(x$number_of_features()), "dgCMatrix"),
as_Matrix(as.matrix(solution[, x$action_names()]), "dgCMatrix"))),
x$feature_names())))
# return output
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.