Exemple #1
0
//' 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);
        }
}
Exemple #2
0
// [[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;
}
Exemple #3
0
//' 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;
}
Exemple #5
0
//[[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);
}
Exemple #6
0
Rcpp::CharacterVector colnames(Rcpp::NumericMatrix x) {
  Rcpp::List dimnames = x.attr("dimnames");
  return(dimnames[1]);
}