//' 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]); }