1
#include <Rcpp.h>
2
// [[Rcpp::plugins(cpp11)]]
3
// [[Rcpp::depends(RcppEigen)]]
4

5
using namespace Rcpp;
6

7

8
#include <vector>
9
#include <string>
10
#include <algorithm>
11
#include <unordered_map>
12
#include <iomanip>
13
#include <iostream>
14
#include <sstream>
15
#include <RcppEigen.h>
16
#include <Rcpp.h>
17
#include "functions.h"
18

19
// [[Rcpp::export]]
20 4
Rcpp::S4 rcpp_extract_model_object(Rcpp::S4 opts, bool unreliable_formulation, Rcpp::S4 data, Rcpp::List model, std::vector<std::string> logging_file, Rcpp::List solution, bool verbose) {
21
 //// Initialization
22
 if (verbose) Rcout << "Initialization" << std::endl;
23
 // variables to store model data
24
 std::size_t n_attribute_spaces_INT;
25
 std::size_t n_pu_INT;
26
 std::size_t n_edges_INT;
27
 std::size_t n_species_INT;
28 4
 Rcpp::List cache_LST=model["cache"];
29

30
 // return variables
31
 double Score;
32 4
 double Cost=0.0;
33 4
 std::size_t Planning_Units=0.0;
34 4
 Environment cacheENV = Environment::base_env();
35

36
 //// Preliminary processing
37
 if (verbose) Rcout << "Preliminary processing" << std::endl;
38 4
 Rcpp::checkUserInterrupt();
39
 /// extract parameters from Rcpp::S4 opts
40
 if (verbose) Rcout << "\tRapOpts" << std::endl;
41 4
 double blmDBL=Rcpp::as<double>(opts.slot("BLM"));
42

43
 /// extract data from Rcpp::S4 data
44
 // species data
45
 if (verbose) Rcout << "\tspecies data" << std::endl;
46 4
 Rcpp::DataFrame species_DF=Rcpp::as<Rcpp::DataFrame>(data.slot("species"));
47 4
 n_species_INT=species_DF.nrows();
48

49
 // planning unit data
50
 if (verbose) Rcout << "\tplanning unit data" << std::endl;
51 4
 Rcpp::DataFrame pu_DF=Rcpp::as<Rcpp::DataFrame>(data.slot("pu"));
52 4
 std::vector<double> pu_DF_area = pu_DF["area"];
53 4
 std::vector<double> pu_DF_cost = pu_DF["cost"];
54 4
 std::vector<std::size_t> pu_DF_status = pu_DF["status"];
55 4
 n_pu_INT=pu_DF_area.size();
56

57
 // pu.species.probabilities
58
 if (verbose) Rcout << "\tpu.species.probabilities data" << std::endl;
59 4
 Rcpp::DataFrame puvspecies_DF=Rcpp::as<Rcpp::DataFrame>(data.slot("pu.species.probabilities"));
60 4
 std::vector<std::size_t> puvspecies_DF_pu = puvspecies_DF["pu"];
61 4
 std::vector<std::size_t> puvspecies_DF_species = puvspecies_DF["species"];
62 4
 std::vector<double> puvspecies_DF_value = puvspecies_DF["value"];
63 4
 for (std::size_t i=0; i<puvspecies_DF_pu.size(); ++i) {
64 4
   puvspecies_DF_pu[i]-=1;
65 4
   puvspecies_DF_species[i]-=1;
66
 }
67

68
 // boundary
69
 if (verbose) Rcout << "\tboundary data" << std::endl;
70 4
 Rcpp::DataFrame boundary_DF=Rcpp::as<Rcpp::DataFrame>(data.slot("boundary"));
71 4
 std::vector<std::size_t> boundary_DF_id1 = boundary_DF["id1"];
72 4
 std::vector<std::size_t> boundary_DF_id2 = boundary_DF["id2"];
73 4
 std::vector<double> boundary_DF_boundary = boundary_DF["boundary"];
74 4
 n_edges_INT=boundary_DF_boundary.size();
75 4
 for (std::size_t i=0; i<n_edges_INT; ++i) {
76 4
   boundary_DF_id1[i]-=1;
77 4
   boundary_DF_id2[i]-=1;
78
 }
79

80
  // target data
81
  if (verbose) Rcpp::Rcout << "\ttarget data" << std::endl;
82 4
  Rcpp::DataFrame target_DF=Rcpp::as<Rcpp::DataFrame>(data.slot("targets"));
83 4
  std::vector<std::size_t> target_DF_species = target_DF["species"];
84 4
  std::vector<std::size_t> target_DF_target = target_DF["target"];
85 4
  std::vector<double> target_DF_value = target_DF["proportion"];
86

87
 /// attribute.space
88
 if (verbose) Rcout << "\tattribute space data" << std::endl;
89 4
 Rcpp::List attributespace_LST=Rcpp::as<Rcpp::List>(data.slot("attribute.spaces"));
90 4
 n_attribute_spaces_INT=attributespace_LST.size();
91

92
 // cache integer string conversions
93
 std::size_t maxINT;
94 4
 maxINT=std::max(
95
   n_pu_INT,
96
   std::max(
97
     n_species_INT,
98
     n_attribute_spaces_INT
99
    )
100 4
  ) + 2;
101 4
 std::vector<std::string> intSTR(maxINT);
102 4
 for (std::size_t i=0; i<maxINT; i++)
103 4
   intSTR[i] = num2str<std::size_t>(i);
104

105
 /// load cached data
106
 if (verbose) Rcout << "\tcached data" << std::endl;
107

108
 // create distance variables
109 4
  std::vector<Eigen::Matrix<double, Eigen::Dynamic, Eigen::Dynamic, Eigen::RowMajor>> species_space_weightdist_MTX = *Rcpp::as<Rcpp::XPtr<std::vector<Eigen::Matrix<double, Eigen::Dynamic, Eigen::Dynamic, Eigen::RowMajor>>>>(cache_LST["wdist"]);
110 4
  std::size_t n_species_attributespace_INT = species_space_weightdist_MTX.size();
111

112

113
  // store ids for attribute spaces and species
114 4
  std::vector<std::size_t> species_attributespace_species_INT=*Rcpp::as<Rcpp::XPtr<std::vector<std::size_t>>>(cache_LST["species_attributespace_species_INT"]);
115 4
  std::vector<std::size_t> species_attributespace_space_INT=*Rcpp::as<Rcpp::XPtr<std::vector<std::size_t>>>(cache_LST["species_attributespace_space_INT"]);
116

117
  // load best values
118 4
  std::vector<double> species_totalarea_DBL = *Rcpp::as<Rcpp::XPtr<std::vector<double>>>(cache_LST["species_totalarea_DBL"]);
119 4
  std::vector<double> species_areatargets_DBL = *Rcpp::as<Rcpp::XPtr<std::vector<double>>>(cache_LST["species_areatargets_DBL"]);
120 4
  std::vector<double> species_space_tss_DBL = *Rcpp::as<Rcpp::XPtr<std::vector<double>>>(cache_LST["species_space_tss_DBL"]);
121 4
  std::vector<double> species_space_rawtargets_DBL = *Rcpp::as<Rcpp::XPtr<std::vector<double>>>(cache_LST["species_space_rawtargets_DBL"]);
122 4
  std::vector<double> species_space_proptargets_DBL = *Rcpp::as<Rcpp::XPtr<std::vector<double>>>(cache_LST["species_space_proptargets_DBL"]);
123 4
  std::vector<double> species_space_best_DBL = *Rcpp::as<Rcpp::XPtr<std::vector<double>>>(cache_LST["species_space_best_DBL"]);
124

125
 //// Main processing
126
 if (verbose) Rcout << "Main processing" << std::endl;
127
 /// simple vars
128
 // extract selections
129
 if (verbose) Rcout << "\tselections" << std::endl;
130 4
 Rcpp::IntegerMatrix selections_MTX(1, n_pu_INT);
131 4
 Rcpp::IntegerVector solutions_RIV=solution["x"];
132 4
 for (std::size_t i=0; i<n_pu_INT; ++i) {
133 4
   selections_MTX(0, i)=solutions_RIV[i];
134 4
   Planning_Units+=selections_MTX(0, i);
135 4
   Cost+=(selections_MTX(0, i) * pu_DF_cost[i]);
136
 }
137

138
 //  extract amountheld
139
 if (verbose) Rcout << "\tamount held" << std::endl;
140 4
 Rcpp::NumericMatrix species_amountheld_MTX(1, n_species_INT);
141 4
 for (std::size_t i=0; i<puvspecies_DF_pu.size(); ++i)
142 4
   if (selections_MTX(0, puvspecies_DF_pu[i])>0)
143 0
     species_amountheld_MTX(0, puvspecies_DF_species[i]) = species_amountheld_MTX(0, puvspecies_DF_species[i]) + puvspecies_DF_value[i] * pu_DF_area[puvspecies_DF_pu[i]];
144 4
 for (std::size_t i=0; i<n_species_INT; ++i)
145 4
   species_amountheld_MTX(0, i)=species_amountheld_MTX(0, i)  / species_totalarea_DBL[i];
146

147
 // extract spaceheld
148
 if (verbose) Rcout << "\tspace held" << std::endl;
149
 if (verbose) Rcout << "\t\trestoring variables from cache" << std::endl;
150
 // restore variables from cache
151 4
  std::vector<std::size_t> species_space_rlevel_INT = *Rcpp::as<Rcpp::XPtr<std::vector<std::size_t>>>(cache_LST["species_space_rlevel_INT"]);
152 4
  std::vector<Rcpp::NumericVector> species_space_pu_probs_RDV = *Rcpp::as<Rcpp::XPtr<std::vector<Rcpp::NumericVector>>>(cache_LST["species_space_pu_probs_RDV"]);
153 4
  std::vector<Rcpp::IntegerVector> species_space_puids_RIV = *Rcpp::as<Rcpp::XPtr<std::vector<Rcpp::IntegerVector>>>(cache_LST["species_space_puids_RIV"]);
154 4
  std::vector<Rcpp::IntegerVector> species_space_pupos_RIV = *Rcpp::as<Rcpp::XPtr<std::vector<Rcpp::IntegerVector>>>(cache_LST["species_space_pupos_RIV"]);
155

156
  // subset variables to those included in the solution
157 4
  std::vector<std::vector<std::size_t>> selected_species_space_puids_INT(n_species_attributespace_INT);
158 4
  std::vector<std::vector<std::size_t>> selected_species_space_pupos_INT(n_species_attributespace_INT);
159 4
  for (std::size_t a=0; a<n_species_attributespace_INT; ++a) {
160 4
    for (std::size_t l=0; l<static_cast<std::size_t>(species_space_puids_RIV[a].size()); ++l) {
161 4
      if (selections_MTX(0,species_space_puids_RIV[a][l])>0) {
162 0
        selected_species_space_pupos_INT[a].push_back(l);
163 0
        selected_species_space_puids_INT[a].push_back(species_space_puids_RIV[a][l]);
164
      }
165
    }
166
  }
167

168
  // calculate spatial representation metrics
169
 if (verbose) Rcout << "\t\tcalculating representation props." << std::endl;
170 4
 Eigen::Matrix<double, Eigen::Dynamic, Eigen::Dynamic> species_space_propheld_MTX(1, n_species_INT*n_attribute_spaces_INT);
171 4
 species_space_propheld_MTX.fill(NAN);
172
 std::size_t curr_matrix_column;
173 4
 for (std::size_t a=0; a<n_species_attributespace_INT; ++a) {
174 4
   curr_matrix_column = (species_attributespace_species_INT[a]*n_attribute_spaces_INT)+species_attributespace_space_INT[a];
175 4
  if (selected_species_space_pupos_INT[a].size() == 0) {
176 4
    species_space_propheld_MTX(0, curr_matrix_column) = -std::numeric_limits<double>::infinity();
177 0
  } else if (unreliable_formulation) {
178 0
    species_space_propheld_MTX(0, curr_matrix_column) = 1.0 - (
179 0
      unreliable_space_value(
180 0
        species_space_weightdist_MTX[a],
181 0
        selected_species_space_pupos_INT[a]
182 0
      ) / species_space_tss_DBL[a]);
183
  } else {
184 0
    species_space_propheld_MTX(0, curr_matrix_column) = 1.0 - (
185 0
      reliable_space_value(
186 0
          species_space_weightdist_MTX[a],
187 0
          selected_species_space_pupos_INT[a],
188 0
          species_space_pu_probs_RDV[a],
189 0
          species_space_rlevel_INT[a]
190 0
      ) / species_space_tss_DBL[a]);
191
  }
192
 }
193

194
 /// calculated vars
195
 // extract summaryDF
196
 if (verbose) Rcout << "\tcalculating connectivity data" << std::endl;
197 4
 std::vector<double>Connectivity=calculateConnectivity(boundary_DF_id1, boundary_DF_id2, boundary_DF_boundary, selections_MTX);
198

199
 // calculate Score
200 4
 Score=Rcpp::as<Rcpp::NumericVector>(solution["objval"])[0];
201 4
 if (Rcpp::NumericVector::is_na(Score))
202 4
  Score=Cost + (blmDBL * Connectivity[2]);
203

204
 // extract solution status
205 4
 std::string solution_status=solution["status"];
206

207
 //// Exports
208
 if (verbose) Rcout << "Exporting data to R" << std::endl;
209 4
 Rcpp::S4 ret("RapResults");
210 4
 ret.slot("summary") = Rcpp::DataFrame::create(
211 4
   Rcpp::Named("Run_Number") = Rcpp::wrap(1),
212 4
   Rcpp::Named("Status") = Rcpp::wrap(solution_status),
213 4
   Rcpp::Named("Score")=Rcpp::wrap(Score),
214 4
   Rcpp::Named("Cost")= Rcpp::wrap(Cost),
215 4
   Rcpp::Named("Planning_Units")= Rcpp::wrap(Planning_Units),
216 4
   Rcpp::Named("Connectivity_Total")= std::accumulate(Connectivity.begin(), Connectivity.end(), 0.0),
217 4
   Rcpp::Named("Connectivity_In")= Connectivity[0],
218 4
   Rcpp::Named("Connectivity_Edge")= Connectivity[1],
219 4
   Rcpp::Named("Connectivity_Out")= Connectivity[2],
220 4
   Rcpp::Named("Connectivity_In_Fraction")= Connectivity[0] / (Connectivity[0]+Connectivity[1]+Connectivity[2])
221
 );
222 4
 ret.slot("selections") = selections_MTX;
223 4
 ret.slot("amount.held") = species_amountheld_MTX;
224 4
 ret.slot("space.held") = Rcpp::wrap(species_space_propheld_MTX);
225 4
 ret.slot("logging.file") = Rcpp::wrap(logging_file);
226 4
 ret.slot("best") = 1;
227 4
 ret.slot(".cache") = cacheENV;
228 4
 return(ret);
229
}

Read our documentation on viewing source code .

Loading