Merge pull request #116 from mrc-ide/dev

Dev

.Rbuildignore

@@ -14,3 +14,4 @@ docs
 codecov.yml
 tests/performance
 joss
+.vscode

R/RcppExports.R

@@ -65,6 +65,10 @@ filter_bitset_bitset <- function(b, other) {
     .Call(`_individual_filter_bitset_bitset`, b, other)
 }
 
+bitset_choose <- function(b, k) {
+    invisible(.Call(`_individual_bitset_choose`, b, k))
+}
+
 create_categorical_variable <- function(categories, values) {
     .Call(`_individual_create_categorical_variable`, categories, values)
 }

R/bitset.R

@@ -6,8 +6,8 @@
 #' WARNING: all operations (except \code{$not}) are in-place so please use \code{$copy} 
 #' if you would like to perform an operation without destroying your current bitset.
 #' @importFrom R6 R6Class
-#' @export Bitset
-Bitset <- R6::R6Class(
+#' @export
+Bitset <- R6Class(
   'Bitset',
   public = list(
     #' @field .bitset a pointer to the underlying IterableBitset
@@ -94,6 +94,17 @@ Bitset <- R6::R6Class(
       }      
       self
     },
+
+    #' @description choose k random items in the bitset
+    #' @param k the number of items in the bitset to keep. The selection of
+    #' these k items from N total items in the bitset is random, and
+    #' k should be chosen such that 0 <= k < N.
+    choose = function(k) {
+      stopifnot(is.finite(k))
+      stopifnot(k < bitset_size(self$.bitset))
+      bitset_choose(self$.bitset, as.integer(k))
+      self
+    },
 
     #' @description returns a copy the bitset
     copy = function() Bitset$new(from = bitset_copy(self$.bitset)),
@@ -117,8 +128,16 @@ Bitset <- R6::R6Class(
 #' @export
 filter_bitset = function(bitset, other) {
   if ( inherits(other, "Bitset")) {
-    return(Bitset$new(from = filter_bitset_bitset(bitset$.bitset, other$.bitset)))
+    if (other$size() > 0) {
+      return(Bitset$new(from = filter_bitset_bitset(bitset$.bitset, other$.bitset)))  
+    } else {
+      return(Bitset$new(size = bitset$max_size))
+    }
   } else {
-    return(Bitset$new(from = filter_bitset_vector(bitset$.bitset, as.integer(other))))
+    if (length(other) > 0) {
+      return(Bitset$new(from = filter_bitset_vector(bitset$.bitset, as.integer(other))))  
+    } else {
+      return(Bitset$new(size = bitset$max_size))
+    }
   }
 }

R/categorical_variable.R

@@ -6,7 +6,7 @@
 #' if possible becuase certain operations will be faster.
 #' @importFrom R6 R6Class
 #' @export
-CategoricalVariable <- R6::R6Class(
+CategoricalVariable <- R6Class(
   'CategoricalVariable',
   public = list(
 

R/double_variable.R

@@ -2,7 +2,7 @@
 #' @description Represents a continuous variable for an individual.
 #' @importFrom R6 R6Class
 #' @export
-DoubleVariable <- R6::R6Class(
+DoubleVariable <- R6Class(
   'DoubleVariable',
   public = list(
     .variable = NULL,

R/event.R

@@ -2,7 +2,7 @@
 #' @description Describes a general event in the simulation
 #' @importFrom R6 R6Class
 #' @export
-Event <- R6::R6Class(
+Event <- R6Class(
   'Event',
   public = list(
 

R/integer_variable.R

@@ -6,7 +6,7 @@
 #' household or age bin.
 #' @importFrom R6 R6Class
 #' @export
-IntegerVariable <- R6::R6Class(
+IntegerVariable <- R6Class(
   'IntegerVariable',
   public = list(
 

R/render.R

@@ -2,7 +2,7 @@
 #' @description Class to render output for the simulation
 #' @importFrom R6 R6Class
 #' @export
-Render <- R6::R6Class(
+Render <- R6Class(
   'Render',
   private = list(
     .vectors = list(),

R/targeted_event.R

@@ -1,8 +1,9 @@
 #' @title TargetedEvent Class
 #' @description Describes a targeted event in the simulation
 #' This is useful for events which are triggered for a sub-population.
+#' @importFrom R6 R6Class
 #' @export
-TargetedEvent <- R6::R6Class(
+TargetedEvent <- R6Class(
   'TargetedEvent',
   inherit = Event,
   public = list(

inst/include/IterableBitset.h

@@ -433,6 +433,35 @@ inline IterableBitset<A> filter_bitset(
     return result;
 }
 
+//' @title randomly keep N items in the bitset
+//' @description retain N items in the bitset. This function
+//' modifies the bitset.
+template<class A>
+inline void bitset_choose_internal(
+    IterableBitset<A>& b,
+    const size_t k
+){
+  auto to_remove = Rcpp::sample(
+    b.size(),
+    b.size() - k,
+    false, // replacement
+    R_NilValue, // evenly distributed
+    false // one based
+  );
+  std::sort(to_remove.begin(), to_remove.end());
+  auto bitset_i = 0u;
+  auto bitset_it = b.cbegin();
+  for (auto i : to_remove) {
+    while(bitset_i != i) {
+      ++bitset_i;
+      ++bitset_it;
+    }
+    b.erase(*bitset_it);
+    ++bitset_i;
+    ++bitset_it;
+  }
+}
+
 //' @title sample the bitset
 //' @description retain a subset of values contained in this bitset, 
 //' where each element has probability 'rate' to remain. 

inst/include/Variable.h

@@ -9,6 +9,7 @@
 
 struct Variable {
     virtual void update() = 0;
+    virtual ~Variable() {};
 };
 
 #endif /* INST_INCLUDE_VARIABLE_H_ */

src/RcppExports.cpp

@@ -187,6 +187,17 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// bitset_choose
+void bitset_choose(const Rcpp::XPtr<individual_index_t> b, const size_t k);
+RcppExport SEXP _individual_bitset_choose(SEXP bSEXP, SEXP kSEXP) {
+BEGIN_RCPP
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< const Rcpp::XPtr<individual_index_t> >::type b(bSEXP);
+    Rcpp::traits::input_parameter< const size_t >::type k(kSEXP);
+    bitset_choose(b, k);
+    return R_NilValue;
+END_RCPP
+}
 // create_categorical_variable
 Rcpp::XPtr<CategoricalVariable> create_categorical_variable(const std::vector<std::string>& categories, const std::vector<std::string>& values);
 RcppExport SEXP _individual_create_categorical_variable(SEXP categoriesSEXP, SEXP valuesSEXP) {
@@ -845,6 +856,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_individual_bitset_to_vector", (DL_FUNC) &_individual_bitset_to_vector, 1},
     {"_individual_filter_bitset_vector", (DL_FUNC) &_individual_filter_bitset_vector, 2},
     {"_individual_filter_bitset_bitset", (DL_FUNC) &_individual_filter_bitset_bitset, 2},
+    {"_individual_bitset_choose", (DL_FUNC) &_individual_bitset_choose, 2},
     {"_individual_create_categorical_variable", (DL_FUNC) &_individual_create_categorical_variable, 2},
     {"_individual_categorical_variable_queue_update", (DL_FUNC) &_individual_categorical_variable_queue_update, 3},
     {"_individual_categorical_variable_get_index_of", (DL_FUNC) &_individual_categorical_variable_get_index_of, 2},

src/bitset.cpp

@@ -155,3 +155,11 @@ Rcpp::XPtr<individual_index_t> filter_bitset_bitset(
         true
     );
 }
+
+//[[Rcpp::export]]
+void bitset_choose(
+        const Rcpp::XPtr<individual_index_t> b,
+        const size_t k
+) {
+    bitset_choose_internal(*b, k);
+}

src/event.cpp

@@ -115,7 +115,7 @@ void process_listener(
 ) {
     size_t t = event->t;
     (*listener)(t);
-};
+}
 
 // [[Rcpp::export]]
 void process_targeted_listener(

src/prefab.cpp

@@ -56,7 +56,7 @@ Rcpp::XPtr<process_t> fixed_probability_multinomial_process_internal(
         }),
         true
     ); 
-};
+}
 
 
 // [[Rcpp::export]]
@@ -105,7 +105,7 @@ Rcpp::XPtr<process_t> multi_probability_multinomial_process_internal(
         }),
         true
     ); 
-};
+}
 
 // [[Rcpp::export]]
 Rcpp::XPtr<process_t> multi_probability_bernoulli_process_internal(
@@ -129,7 +129,7 @@ Rcpp::XPtr<process_t> multi_probability_bernoulli_process_internal(
         }),
         true
     ); 
-};
+}
 
 // [[Rcpp::export]]
 Rcpp::XPtr<process_t> infection_age_process_internal(

tests/testthat/test-bitset.R

@@ -167,9 +167,47 @@ test_that("bitset filtering works for bitsets", {
   expect_equal(filter_bitset(b, f)$to_vector(), c(1, 6))
 })
 
+test_that("bitset filtering works when given empty index", {
+  b <- Bitset$new(10)$insert(c(1, 5, 6))
+  f <- Bitset$new(10)
+  expect_equal(filter_bitset(b, f)$size(), 0)
+  expect_equal(filter_bitset(b, integer(0))$size(), 0)
+})
+
 test_that("bitset throws error when given bad input probabilities in sample", {
   b <- Bitset$new(10)$insert(1:10)
   expect_error(
     b$sample(rate = c(rep(0.1,9),NA))
   )
 })
+
+test_that("bitset choose behaves properly when given an empty bitset", {
+  b <- Bitset$new(10)
+  expect_error(
+    b$choose(5)
+  )
+  expect_error(
+    b$choose(-1)
+  )
+  expect_error(
+    b$choose(100)
+  )
+  expect_error(
+    b$choose(Inf)
+  )
+})
+
+test_that("bitset choose behaves properly when given a bitset with elements", {
+
+  b <- Bitset$new(10)$insert(1:8)
+  expect_equal(b$copy()$or(b$copy()$choose(5))$to_vector(), b$to_vector()) # check that b$choose is a subset of b
+
+  b <- Bitset$new(10)$insert(1:8)
+  expect_equal(b$choose(5)$size(), 5)
+
+  b <- Bitset$new(10)$insert(1:8)
+  expect_equal(b$choose(0)$size(), 0)
+
+  b <- Bitset$new(10)$insert(1:8)
+  expect_error(b$choose(8))
+})