//' Evaluate the log-density of the measurement process by calling measurement
//' process density functions via external Xptr.
//'
//' @param emitmat matrix of emission probabilities
//' @param obsmat matrix containing the data
//' @param statemat matrix containing the compartment counts at the observation
//' times
//' @param measproc_indmat logical matrix indicating which compartments are
//' observed at every observation time
//' @param parameters numeric vector of parameter values
//' @param constants numeric vector of constants
//' @param tcovar_censusmat numeric vector of time-varying covariate values
//' @param d_meas_ptr external pointer to measurement process density function
//'
//' @export
// [[Rcpp::export]]
void evaluate_d_measure(Rcpp::NumericMatrix& emitmat, const Rcpp::NumericMatrix& obsmat,
const Rcpp::NumericMatrix& statemat, const Rcpp::LogicalMatrix& measproc_indmat,
const Rcpp::NumericVector& parameters, const Rcpp::NumericVector& constants,
const Rcpp::NumericMatrix& tcovar_censusmat, SEXP d_meas_ptr) {
// get dimensions
Rcpp::IntegerVector emit_dims = emitmat.attr("dim");
// evaluate the densities
for(int j=0; j < emit_dims[0]; ++j) {
// args: emitmat, emit_inds, record_ind, record, state, parameters, constants, tcovar, pointer
CALL_D_MEASURE(emitmat, measproc_indmat.row(j), j, obsmat.row(j), statemat.row(j), parameters, constants, tcovar_censusmat.row(j), d_meas_ptr);
}
}
// [[Rcpp::export]]
NumericMatrix windowize_NM(Rcpp::NumericMatrix x, Rcpp::NumericVector pos,
Rcpp::NumericVector starts, Rcpp::NumericVector ends,
Rcpp::String summary="mean") {
// Declare a matrix for output.
Rcpp::NumericMatrix outM(starts.size(), x.ncol());
Rcpp::List dimnames = x.attr("dimnames");
dimnames(0) = Rcpp::CharacterVector::create();
outM.attr("dimnames") = dimnames;
// Declare a vector of a vector of doubles to hold each
// window prior to summarization.
std::vector < std::vector < double > > window_tmp(x.ncol());
// Counters
int window_num = 0;
int i; // Variant counter
int j; // Sample counter
// Manage the first variant.
while(pos(0) > ends(window_num)){
window_num++;
}
// Scroll over variants.
for(i = 0; i < pos.size(); i++){
if(pos(i) > ends(window_num)){
// Summarize window.
// Rcout << " Sumarizing window " << window_num << ", size is: " << window_tmp[0].size() << "\n";
if(summary == "mean"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_mean(window_tmp[j]);
window_tmp[j].clear();
window_tmp[j].push_back(x(i,j));
}
}
if(summary == "median"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_median(window_tmp[j]);
window_tmp[j].clear();
window_tmp[j].push_back(x(i,j));
}
}
if(summary == "sum"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_sum(window_tmp[j]);
window_tmp[j].clear();
window_tmp[j].push_back(x(i,j));
}
}
if(summary == "count"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_count(window_tmp[j]);
window_tmp[j].clear();
window_tmp[j].push_back(x(i,j));
}
}
window_num++;
} else {
// Add values to current window.
for(j=0; j<x.ncol(); j++){
if(x(i,j) != NA_REAL){
window_tmp[j].push_back(x(i,j));
}
}
}
// Rcout << "i: " << i << ", pos: " << pos(i) << ", window_num:" << window_num << "\n";
}
// Summarize the last window.
if(summary == "mean"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_mean(window_tmp[j]);
window_tmp[j].clear();
}
}
if(summary == "median"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_median(window_tmp[j]);
window_tmp[j].clear();
}
}
if(summary == "sum"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_sum(window_tmp[j]);
window_tmp[j].clear();
}
}
if(summary == "count"){
for(j=0; j<x.ncol(); j++){
outM(window_num, j) = vector_count(window_tmp[j]);
window_tmp[j].clear();
}
}
return outM;
}
//' rcpp_get_polygons
//'
//' Extracts all polygons from an overpass API query
//'
//' @param st Text contents of an overpass API query
//' @return A \code{SpatialLinesDataFrame} contains all polygons and associated data
// [[Rcpp::export]]
Rcpp::S4 rcpp_get_polygons (const std::string& st)
{
#ifdef DUMP_INPUT
{
std::ofstream dump ("./get-polygons.xml");
if (dump.is_open())
{
dump.write (st.c_str(), st.size());
}
}
#endif
XmlPolys xml (st);
const std::map <osmid_t, Node>& nodes = xml.nodes ();
const std::map <osmid_t, OneWay>& ways = xml.ways ();
const std::vector <Relation>& rels = xml.relations ();
int count = 0;
float xmin = FLOAT_MAX, xmax = -FLOAT_MAX,
ymin = FLOAT_MAX, ymax = -FLOAT_MAX;
std::vector <float> lons, lats;
std::unordered_set <std::string> idset; // see TODO below
std::vector <std::string> colnames, rownames, polynames;
std::set <std::string> varnames;
Rcpp::List dimnames (0), dummy_list (0);
Rcpp::NumericMatrix nmat (Rcpp::Dimension (0, 0));
idset.clear ();
colnames.push_back ("lon");
colnames.push_back ("lat");
varnames.insert ("name");
// other varnames added below
/*
* NOTE: Nodes are first loaded into the 2 vectors of (lon, lat), and these
* are then copied into nmat. This intermediate can be avoided by loading
* directly into nmat using direct indexing rather than iterators, however
* this does *NOT* make the routine any faster, and so the current version
* which more safely uses iterators is kept instead.
*/
Rcpp::Environment sp_env = Rcpp::Environment::namespace_env ("sp");
Rcpp::Function Polygon = sp_env ["Polygon"];
Rcpp::Language polygons_call ("new", "Polygons");
Rcpp::S4 polygons;
/*
* Polygons are extracted from the XmlPolys class in three setps:
* 1. Get the names of all polygons that are part of multipolygon relations
* 2. Get the names of any remaining ways that are polygonal (start == end)
* 3. From the resultant list, extract the actual polygonal ways
*
* NOTE: OSM polygons are stored as ways, and thus all objects in the class
* xmlPolys are rightly referred to as ways. Here within this Rcpp function,
* these are referred to as Polygons, but the iteration is over the actual
* polygonal ways.
*/
// Step#1
std::set <osmid_t> the_ways; // Set will only insert unique values
for (auto it = rels.begin (); it != rels.end (); ++it)
for (auto itw = (*it).ways.begin (); itw != (*it).ways.end (); ++itw)
{
assert (ways.find (itw->first) != ways.end ());
the_ways.insert (itw->first);
}
// Step#2
//const std::map <osmid_t, OneWay>& ways = xml.ways ();
for (auto it = ways.begin (); it != ways.end (); ++it)
{
if (the_ways.find ((*it).first) == the_ways.end ())
if ((*it).second.nodes.begin () == (*it).second.nodes.end ())
the_ways.insert ((*it).first);
}
// Step#2b - Erase any ways that contain no data (should not happen).
for (auto it = the_ways.begin (); it != the_ways.end (); )
{
auto itw = ways.find (*it);
if (itw->second.nodes.size () == 0)
it = the_ways.erase (it);
else
++it;
}
Rcpp::List polyList (the_ways.size ());
// Step#3 - Extract and store the_ways
for (auto it = the_ways.begin (); it != the_ways.end (); ++it)
{
auto itw = ways.find (*it);
// Collect all unique keys
std::for_each (itw->second.key_val.begin (),
itw->second.key_val.end (),
[&](const std::pair <std::string, std::string>& p)
{
varnames.insert (p.first);
});
/*
* The following lines check for duplicate way IDs -- which do very
* occasionally occur -- and ensures unique values as required by 'sp'
* through appending decimal digits to <osmid_t> OSM IDs.
*/
std::string id = std::to_string (itw->first);
int tempi = 0;
while (idset.find (id) != idset.end ())
id = std::to_string (itw->first) + "." + std::to_string (tempi++);
idset.insert (id);
polynames.push_back (id);
// Then iterate over nodes of that way and store all lat-lons
size_t n = itw->second.nodes.size ();
lons.clear ();
lats.clear ();
rownames.clear ();
lons.reserve (n);
lats.reserve (n);
rownames.reserve (n);
for (auto itn = itw->second.nodes.begin ();
itn != itw->second.nodes.end (); ++itn)
{
// TODO: Propoer exception handler
assert (nodes.find (*itn) != nodes.end ());
lons.push_back (nodes.find (*itn)->second.lon);
lats.push_back (nodes.find (*itn)->second.lat);
rownames.push_back (std::to_string (*itn));
}
xmin = std::min (xmin, *std::min_element (lons.begin(), lons.end()));
xmax = std::max (xmax, *std::max_element (lons.begin(), lons.end()));
ymin = std::min (ymin, *std::min_element (lats.begin(), lats.end()));
ymax = std::max (ymax, *std::max_element (lats.begin(), lats.end()));
nmat = Rcpp::NumericMatrix (Rcpp::Dimension (lons.size (), 2));
std::copy (lons.begin (), lons.end (), nmat.begin ());
std::copy (lats.begin (), lats.end (), nmat.begin () + lons.size ());
// This only works with push_back, not with direct re-allocation
dimnames.push_back (rownames);
dimnames.push_back (colnames);
nmat.attr ("dimnames") = dimnames;
dimnames.erase (0, dimnames.size());
//Rcpp::S4 poly = Rcpp::Language ("Polygon", nmat).eval ();
Rcpp::S4 poly = Polygon (nmat);
dummy_list.push_back (poly);
polygons = polygons_call.eval ();
polygons.slot ("Polygons") = dummy_list;
polygons.slot ("ID") = id;
polyList [count++] = polygons;
dummy_list.erase (0);
} // end for it over the_ways
polyList.attr ("names") = polynames;
// Store all key-val pairs in one massive DF
int nrow = the_ways.size (), ncol = varnames.size ();
Rcpp::CharacterVector kv_vec (nrow * ncol, Rcpp::CharacterVector::get_na ());
int namecoli = std::distance (varnames.begin (), varnames.find ("name"));
for (auto it = the_ways.begin (); it != the_ways.end (); ++it)
{
int rowi = std::distance (the_ways.begin (), it);
auto itw = ways.find (*it);
kv_vec (namecoli * nrow + rowi) = itw->second.name;
for (auto kv_iter = itw->second.key_val.begin ();
kv_iter != itw->second.key_val.end (); ++kv_iter)
{
const std::string& key = (*kv_iter).first;
auto ni = varnames.find (key); // key must exist in varnames!
int coli = std::distance (varnames.begin (), ni);
kv_vec (coli * nrow + rowi) = (*kv_iter).second;
}
}
Rcpp::Language sp_polys_call ("new", "SpatialPolygonsDataFrame");
Rcpp::S4 sp_polys = sp_polys_call.eval ();
sp_polys.slot ("polygons") = polyList;
sp_polys.slot ("bbox") = rcpp_get_bbox (xmin, xmax, ymin, ymax);
Rcpp::Language crs_call ("new", "CRS");
Rcpp::S4 crs = crs_call.eval ();
crs.slot ("projargs") = "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0";
sp_polys.slot ("proj4string") = crs;
Rcpp::CharacterMatrix kv_mat (nrow, ncol, kv_vec.begin());
Rcpp::DataFrame kv_df = kv_mat;
kv_df.attr ("names") = varnames;
sp_polys.slot ("data") = kv_df;
return sp_polys;
}
//' rcpp_lines_as_network
//'
//' Return OSM data in Simple Features format
//'
//' @param sf_lines An sf collection of LINESTRING objects
//' @param pr Rcpp::DataFrame containing the weighting profile
//'
//' @return Rcpp::List objects of OSM data
//'
//' @noRd
// [[Rcpp::export]]
Rcpp::List rcpp_lines_as_network (const Rcpp::List &sf_lines,
Rcpp::DataFrame pr)
{
std::map <std::string, float> profile;
Rcpp::StringVector hw = pr [1];
Rcpp::NumericVector val = pr [2];
for (int i = 0; i != hw.size (); i ++)
profile.insert (std::make_pair (std::string (hw [i]), val [i]));
Rcpp::CharacterVector nms = sf_lines.attr ("names");
if (nms [nms.size () - 1] != "geometry")
throw std::runtime_error ("sf_lines have no geometry component");
if (nms [0] != "osm_id")
throw std::runtime_error ("sf_lines have no osm_id component");
int one_way_index = -1;
int one_way_bicycle_index = -1;
int highway_index = -1;
for (int i = 0; i < nms.size (); i++)
{
if (nms [i] == "oneway")
one_way_index = i;
if (nms [i] == "oneway.bicycle")
one_way_bicycle_index = i;
if (nms [i] == "highway")
highway_index = i;
}
Rcpp::CharacterVector ow = NULL;
Rcpp::CharacterVector owb = NULL;
Rcpp::CharacterVector highway = NULL;
if (one_way_index >= 0)
ow = sf_lines [one_way_index];
if (one_way_bicycle_index >= 0)
owb = sf_lines [one_way_bicycle_index];
if (highway_index >= 0)
highway = sf_lines [highway_index];
if (ow.size () > 0)
{
if (ow.size () == owb.size ())
{
for (unsigned i = 0; i != ow.size (); ++ i)
if (ow [i] == "NA" && owb [i] != "NA")
ow [i] = owb [i];
} else if (owb.size () > ow.size ())
ow = owb;
}
Rcpp::List geoms = sf_lines [nms.size () - 1];
std::vector<bool> isOneWay (geoms.length ());
std::fill (isOneWay.begin (), isOneWay.end (), false);
// Get dimension of matrix
size_t nrows = 0;
int ngeoms = 0;
for (auto g = geoms.begin (); g != geoms.end (); ++g)
{
// Rcpp uses an internal proxy iterator here, NOT a direct copy
Rcpp::NumericMatrix gi = (*g);
int rows = gi.nrow () - 1;
nrows += rows;
if (ngeoms < ow.size ())
{
if (!(ow [ngeoms] == "yes" || ow [ngeoms] == "-1"))
{
nrows += rows;
isOneWay [ngeoms] = true;
}
}
ngeoms ++;
}
Rcpp::NumericMatrix nmat = Rcpp::NumericMatrix (Rcpp::Dimension (nrows, 6));
Rcpp::CharacterMatrix idmat = Rcpp::CharacterMatrix (Rcpp::Dimension (nrows,
3));
nrows = 0;
ngeoms = 0;
int fake_id = 0;
for (auto g = geoms.begin (); g != geoms.end (); ++ g)
{
Rcpp::NumericMatrix gi = (*g);
std::string hway = std::string (highway [ngeoms]);
float hw_factor = profile [hway];
if (hw_factor == 0.0) hw_factor = 1e-5;
hw_factor = 1.0 / hw_factor;
Rcpp::List ginames = gi.attr ("dimnames");
Rcpp::CharacterVector rnms;
if (ginames.length () > 0)
rnms = ginames [0];
else
{
rnms = Rcpp::CharacterVector (gi.nrow ());
for (int i = 0; i < gi.nrow (); i ++)
rnms [i] = fake_id ++;
}
if (rnms.size () != gi.nrow ())
throw std::runtime_error ("geom size differs from rownames");
for (int i = 1; i < gi.nrow (); i ++)
{
float d = haversine (gi (i-1, 0), gi (i-1, 1), gi (i, 0),
gi (i, 1));
nmat (nrows, 0) = gi (i-1, 0);
nmat (nrows, 1) = gi (i-1, 1);
nmat (nrows, 2) = gi (i, 0);
nmat (nrows, 3) = gi (i, 1);
nmat (nrows, 4) = d;
nmat (nrows, 5) = d * hw_factor;
idmat (nrows, 0) = rnms (i-1);
idmat (nrows, 1) = rnms (i);
idmat (nrows, 2) = hway;
nrows ++;
if (isOneWay [ngeoms])
{
nmat (nrows, 0) = gi (i, 0);
nmat (nrows, 1) = gi (i, 1);
nmat (nrows, 2) = gi (i-1, 0);
nmat (nrows, 3) = gi (i-1, 1);
nmat (nrows, 4) = d;
nmat (nrows, 5) = d * hw_factor;
idmat (nrows, 0) = rnms (i);
idmat (nrows, 1) = rnms (i-1);
idmat (nrows, 2) = hway;
nrows ++;
}
}
ngeoms ++;
}
Rcpp::List res (2);
res [0] = nmat;
res [1] = idmat;
return res;
}
//[[Rcpp::export]]
Rcpp::NumericMatrix SUPERMATRIX(Rcpp::List a,bool keep_names) {
size_t i,j,k;
Rcpp::NumericMatrix mat;
int tot=0;
Rcpp::CharacterVector rnam;
Rcpp::CharacterVector cnam;
Rcpp::CharacterVector this_nam;
Rcpp::List dnames(2);
bool any_rnames=false;
bool any_cnames=false;
for(i=0; i < a.size(); i++) {
mat = Rcpp::as<Rcpp::NumericMatrix>(a[i]);
if(mat.nrow() ==0) continue;
if(mat.nrow() != mat.ncol()) Rcpp::stop("Not all matrices are square");
tot = tot + mat.nrow();
if(!keep_names) continue;
dnames = mat.attr("dimnames");
if(dnames.size()==0) {
for(j=0; j < mat.nrow(); j++) {
rnam.push_back(".");
cnam.push_back(".");
}
continue;
}
if(!Rf_isNull(dnames[0])) {
any_rnames=true;
this_nam = dnames[0];
for(j=0; j< this_nam.size(); j++) rnam.push_back(this_nam[j]);
} else {
for(j=0; j < mat.nrow(); j++) rnam.push_back(".");
}
if(!Rf_isNull(dnames[1])) {
any_cnames=true;
this_nam = dnames[1];
for(j=0; j< this_nam.size(); j++) cnam.push_back(this_nam[j]);
} else {
for(j=0; j < mat.ncol(); j++) cnam.push_back(".");
}
}
int totrow = 0;
int totcol = 0;
Rcpp::NumericMatrix ret(tot,tot);
for(i=0; i < a.size(); i++) {
mat = Rcpp::as<Rcpp::NumericMatrix>(a[i]);
for(j=0; j < mat.nrow(); j++) {
for(k=0; k < mat.ncol(); k++) {
ret(totrow+j,totcol+k) = mat(j,k);
}
}
totrow = totrow + mat.nrow();
totcol = totcol + mat.ncol();
}
if(keep_names) {
Rcpp::List dn = Rcpp::List::create(rnam,cnam);
ret.attr("dimnames") = dn;
}
return(ret);
}
Rcpp::CharacterVector colnames(Rcpp::NumericMatrix x) {
Rcpp::List dimnames = x.attr("dimnames");
return(dimnames[1]);
}