#' Wrapper for vectorizing \code{one_run()}.
#'
#' @param parms a list of parameters.
#' @param exp_des the fulls set of parameter combinations to run the prioritization on.
#' @param parallel a logical determining wheather the vectorization is performed in parallel.
#' @inheritParams one_run
#' @inheritParams components_OF
#'
#' @export
wrapper <- function(parms,
exp_des,
site_threat_array,
planning_unit,
cons_feat_array,
site_species_array,
species_responses,
parallel){
fixed_targets <- parms$fixed_targets
occurrence_limits <- parms$occurrence_limits
target_limits <- parms$target_limits
if(!fixed_targets){
cons_feat_array <- set_scaled_targets(cons_feat_array,
occurrence_limits,
target_limits)
}
exp_des_ls <- df_to_list(exp_des, use_names = TRUE)
if(parallel){
n_cores <- parallel::detectCores() - 1
context::parallel_cluster_start(n_cores, ctx)
}
out <- loop(exp_des_ls,
one_run,
parms,
site_threat_array,
planning_unit,
cons_feat_array,
site_species_array,
species_responses,
parallel = parallel)
if(parallel){
context::parallel_cluster_stop()
}
out
}
#' Reshape the data in the desired form and feed them to the function which runs
#' the prioritization. Collects the outputs as well.
#'
#' @param x a one line data frame with the parameters to be used in the run.
#' @param parms a list of parameters.
#' @param planning_unit a matrix of the cost of abating completely each threat (columns)
#' in each site.
#' @inheritParams components_OF
#'
#' @export
one_run <- function(x,
parms,
site_threat_array,
planning_unit,
cons_feat_array,
site_species_array,
species_responses) {
#browser()
fixed_targets <- parms$fixed_targets
ID_exp <- x$ID_exp
cat("ID experiment =", ID_exp, "\n")
ID_run <- x$ID_run
cat("ID run =", ID_run, "\n")
estimate <- 1 # at the moment we use experts' best estimates for the prioritization
site_threat_array_cat <- get.threat.intensity.category(parms, site_threat_array)
all_site_action_int_combs <- get.site.action.intensities.combs(parms, site_threat_array_cat)
action_costs <- get.action.costs(site_threat_array_cat, planning_unit)
responses_to_actions <- get.responses.to.actions(species_responses, cons_feat_array, estimate)
responses_to_actions.best_guesses <- get.responses.to.actions(species_responses, cons_feat_array, estimate = 1)
required_actions <- get.required_actions(site_threat_array_cat, responses_to_actions.best_guesses, cons_feat_array)
site_action_array <- site_threat_array_cat
site_action_array[] <- 0
if(fixed_targets){
target_level <- x$target_level
cat("target level =", target_level, "\n")
cons_feat_array <- set_fixed_targets(cons_feat_array, site_species_array, target_level)
}
spf_values <- parms$spf
cons_feat_array[, "spf"] <- spf_values
# run the optimization
run <- Optimize(parms,
cons_feat_array,
all_site_action_int_combs,
site_action_array,
action_costs,
site_threat_array_cat,
responses_to_actions,
site_species_array,
required_actions)
ann_summary <- run[[2]]
site_action_array <- run[[3]]
SpeciesBenefit_mat <- run[[4]]
final_species_benefit <- sum(SpeciesBenefit_mat)
final_cost <- as.vector(ann_summary[nrow(ann_summary), "CostCount"])
final_species_penalty <- as.vector(ann_summary[nrow(ann_summary), "PenaltyCount"])
final_obj_fun_value <- as.vector(ann_summary[nrow(ann_summary), "OF"])
no_PUs <- length(which(apply(site_action_array, 1, function(x) min(sum(x),1))==1))
# # write out the annealing summary
# out_pth <- file.path("output", paste("exp", ID_exp, sep="_"), "annealing_summaries")
# dir.create(out_pth, FALSE, TRUE)
# annealing_summary_name <- sprintf("annealing_summary_%s%s", paste("run", ID_run, sep="_"), ".rds")
# saveRDS(ann_summary, file.path(out_pth, annealing_summary_name))
output <- list()
output$exp <- ID_exp
output$run <- ID_run
output$cost <- final_cost # needed
output$species_benefit <- final_species_benefit # needed
output$species_penalty <- final_species_penalty # needed
output$OF_value <- final_obj_fun_value # needed
output$site_action_array <- site_action_array # needed
output$species_benefit_array <- SpeciesBenefit_mat
output$no_pu <- no_PUs # needed
output$targets <- cons_feat_array[,"target"] # needed
output$summary <- ann_summary # needed
output
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.