diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 89286443..a35eaac0 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -18,8 +18,7 @@ jobs: config: - {os: windows-latest, r: 'release'} - {os: macOS-latest, r: 'release'} - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest", http-user-agent: "R/4.1.0 (ubuntu-20.04) R (4.1.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions" } + - {os: ubuntu-latest, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} env: R_REMOTES_NO_ERRORS_FROM_WARNINGS: true @@ -43,7 +42,7 @@ jobs: shell: Rscript {0} - name: Restore R package cache - uses: actions/cache@v2 + uses: actions/cache@v4 with: path: ${{ env.R_LIBS_USER }} key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} diff --git a/.github/workflows/pkgdown.yml b/.github/workflows/pkgdown.yml index 3b8baf9d..5422bddb 100644 --- a/.github/workflows/pkgdown.yml +++ b/.github/workflows/pkgdown.yml @@ -30,7 +30,7 @@ jobs: shell: Rscript {0} - name: Cache R packages - uses: actions/cache@v2 + uses: actions/cache@v4 with: path: ${{ env.R_LIBS_USER }} key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} diff --git a/.github/workflows/test_coverage.yml b/.github/workflows/test_coverage.yml index b8f2c4de..09b00989 100644 --- a/.github/workflows/test_coverage.yml +++ b/.github/workflows/test_coverage.yml @@ -27,7 +27,7 @@ jobs: shell: Rscript {0} - name: Cache R packages - uses: actions/cache@v2 + uses: actions/cache@v4 with: path: ${{ env.R_LIBS_USER }} key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} diff --git a/DESCRIPTION b/DESCRIPTION index 9ead8fdb..c21f32d5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: individual Title: Framework for Specifying and Simulating Individual Based Models -Version: 0.1.17 +Version: 0.1.18 Authors@R: c( person( given = "Giovanni", @@ -65,7 +65,7 @@ Suggests: testthat (>= 2.1.0), xml2, bench -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 VignetteBuilder: knitr LinkingTo: Rcpp, diff --git a/NAMESPACE b/NAMESPACE index 687b7c48..8017a4d2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ export(RaggedInteger) export(Render) export(TargetedEvent) export(bernoulli_process) +export(bitset_count_and) export(categorical_count_renderer_process) export(filter_bitset) export(fixed_probability_multinomial_process) diff --git a/NEWS.md b/NEWS.md index 8763718e..04baa27f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# individual 0.1.18 + + * add $get_values to CategoricalVariable + * add $get_modulo_differences to IntegerVariable + * add bitset_count_and for quick intersection counts + # individual 0.1.17 * Add a `copy_from` method to the `Bitset` class. diff --git a/R/RcppExports.R b/R/RcppExports.R index e8f29628..f0788dc2 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -81,6 +81,10 @@ bitset_choose <- function(b, k) { invisible(.Call(`_individual_bitset_choose`, b, k)) } +bitset_count_and_cpp <- function(a, b) { + .Call(`_individual_bitset_count_and_cpp`, a, b) +} + create_categorical_variable <- function(categories, values) { .Call(`_individual_create_categorical_variable`, categories, values) } @@ -125,6 +129,14 @@ categorical_variable_queue_shrink_bitset <- function(variable, index) { invisible(.Call(`_individual_categorical_variable_queue_shrink_bitset`, variable, index)) } +categorical_variable_get_values <- function(variable) { + .Call(`_individual_categorical_variable_get_values`, variable) +} + +categorical_variable_get_values_with_index <- function(variable, index) { + .Call(`_individual_categorical_variable_get_values_with_index`, variable, index) +} + create_double_variable <- function(values) { .Call(`_individual_create_double_variable`, values) } @@ -289,6 +301,10 @@ integer_variable_get_values <- function(variable) { .Call(`_individual_integer_variable_get_values`, variable) } +integer_variable_get_modulo_differences <- function(variable, value, difference) { + .Call(`_individual_integer_variable_get_modulo_differences`, variable, value, difference) +} + integer_variable_get_values_at_index <- function(variable, index) { .Call(`_individual_integer_variable_get_values_at_index`, variable, index) } diff --git a/R/bitset.R b/R/bitset.R index 7c551a82..b0da4409 100644 --- a/R/bitset.R +++ b/R/bitset.R @@ -291,3 +291,15 @@ filter_bitset = function(bitset, other) { } } } + +#' @title Count bitset and +#' @description This non-modifying function returns the number of intersecting +#' elements between two bitsets \code{a} and \code{b}. This should be faster than +#' writing \code{a$copy()$and(b)$size()} as it avoids the memory allocations of $copy(). +#' +#' @param a a \code{\link{Bitset}} +#' @param b another \code{\link{Bitset}} +#' @export +bitset_count_and = function(a, b) { + bitset_count_and_cpp(a$.bitset, b$.bitset) +} diff --git a/R/categorical_variable.R b/R/categorical_variable.R index 8a172b14..bce3a8e3 100644 --- a/R/categorical_variable.R +++ b/R/categorical_variable.R @@ -43,6 +43,20 @@ CategoricalVariable <- R6Class( categorical_variable_get_categories(self$.variable) }, + #' @description return the value of the variable for the given individuals + #' @param index the indices of individuals whose categories will be returned + get_values = function(index = NULL) { + stopifnot(is.finite(index)) + stopifnot(index > 0) + if (length(index) == 0){ + results <- categorical_variable_get_values(self$.variable) + } + else{ + results <- categorical_variable_get_values_with_index(self$.variable, index) + } + return(results) + }, + #' @description queue an update for this variable #' @param value the new value #' @param index the indices of individuals whose value will be updated diff --git a/R/integer_variable.R b/R/integer_variable.R index 2e3543e2..f39b0e11 100644 --- a/R/integer_variable.R +++ b/R/integer_variable.R @@ -39,6 +39,17 @@ IntegerVariable <- R6Class( }, + #' @description Return a vector of individuals with 0 modulo difference from input value + #' and the distance being compared + #' @param value the value to check + #' @param difference the difference to check, e.g. difference = 2 checks whether the + #' difference is even + get_modulo_differences = function(value, difference){ + stopifnot(is.finite(value)) + stopifnot(is.finite(difference)) + integer_variable_get_modulo_differences(self$.variable, value, difference) + }, + #' @description Return a \code{\link[individual]{Bitset}} for individuals with some subset of values. #' Either search for indices corresponding to values in \code{set}, or #' for indices corresponding to values in range \eqn{[a,b]}. Either \code{set} diff --git a/_pkgdown.yml b/_pkgdown.yml index 1283d2a4..b889b3a1 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -12,6 +12,7 @@ reference: - RaggedDouble - Bitset - filter_bitset + - bitset_count_and - title: "Events & Rendering" desc: "Classes for events and rendering output." - contents: diff --git a/inst/include/CategoricalVariable.h b/inst/include/CategoricalVariable.h index 69a631c6..91e1ce18 100644 --- a/inst/include/CategoricalVariable.h +++ b/inst/include/CategoricalVariable.h @@ -52,6 +52,8 @@ class CategoricalVariable : public Variable { virtual void resize() override; virtual size_t size() const override; virtual void update() override; + virtual std::vector get_values(const std::vector&); + virtual std::vector get_values(); }; @@ -228,5 +230,46 @@ inline size_t CategoricalVariable::size() const { inline const std::vector& CategoricalVariable::get_categories() const { return categories; } - +//' @title get values at index given by a vector +inline std::vector CategoricalVariable::get_values(const std::vector& index){ + + // Generate empty output vector + auto result = std::vector(index.size()); + for (auto i = 0u; i < index.size(); ++i) { + // Determine which category the individual is within + for (auto cat: categories) { + if (indices.find(cat) == indices.end()) { + std::stringstream message; + message << "unknown category: " << cat; + Rcpp::stop(message.str()); + } + if (indices.at(cat).find(index[i]) != indices.at(cat).end()) { + result[i] = cat; + break; + } + } + } + return result; +} +//' @title get values of full variable +inline std::vector CategoricalVariable::get_values(){ + + // Generate empty output vector + auto result = std::vector(size()); + for(auto i = 0u; i < size(); ++i){ + // Determine which category the individual is within + for (auto cat: categories) { + if (indices.find(cat) == indices.end()) { + std::stringstream message; + message << "unknown category: " << cat; + Rcpp::stop(message.str()); + } + if (indices.at(cat).find(i) != indices.at(cat).end()) { + result[i] = cat; + break; + } + } + } + return result; +} #endif /* INST_INCLUDE_CATEGORICAL_VARIABLE_H_ */ diff --git a/inst/include/IntegerVariable.h b/inst/include/IntegerVariable.h index 346ee6db..294075b0 100644 --- a/inst/include/IntegerVariable.h +++ b/inst/include/IntegerVariable.h @@ -30,6 +30,7 @@ struct IntegerVariable : public NumericVariable { virtual size_t get_size_of_set(const std::vector&) const; virtual size_t get_size_of_set(const int) const; virtual size_t get_size_of_range(const int, const int) const; + virtual individual_index_t get_modulo_differences(const int, const int) const; }; inline IntegerVariable::IntegerVariable(const std::vector& values) @@ -66,6 +67,23 @@ inline individual_index_t IntegerVariable::get_index_of_set( return result; } +//' @title return bitset giving index of individuals whose difference between +// the current value and the queried value is a multiple of the queried difference +inline individual_index_t IntegerVariable::get_modulo_differences( + const int value, + const int difference +) const { + + auto result = individual_index_t(size()); + for (auto i = 0u; i < values.size(); ++i) { + if ( (values[i] - value) % difference == 0 ) { + result.insert(i); + } + } + + return result; +} + //' @title return bitset giving index of individuals whose value is in some range [a,b] inline individual_index_t IntegerVariable::get_index_of_range( const int a, const int b diff --git a/inst/include/IterableBitset.h b/inst/include/IterableBitset.h index 6643aaf9..a942f62b 100644 --- a/inst/include/IterableBitset.h +++ b/inst/include/IterableBitset.h @@ -79,6 +79,7 @@ class IterableBitset { IterableBitset& operator&=(const IterableBitset&); IterableBitset& operator|=(const IterableBitset&); IterableBitset& operator^=(const IterableBitset&); + size_t count_and(const IterableBitset&) const; IterableBitset& clear(); IterableBitset& inverse(); iterator begin(); @@ -293,6 +294,18 @@ inline IterableBitset& IterableBitset::operator &=(const IterableBitset return *this; } +template +inline size_t IterableBitset::count_and(const IterableBitset& other) const { + if (max_size() != other.max_size()) { + Rcpp::stop("Incompatible bitmap sizes"); + } + auto n = 0u; + for (auto i = 0u; i < bitmap.size(); ++i) { + n += popcount(bitmap[i] & other.bitmap[i]); + } + return n; +} + template inline IterableBitset& IterableBitset::operator |=(const IterableBitset& other) { if (max_size() != other.max_size()) { diff --git a/man/CategoricalVariable.Rd b/man/CategoricalVariable.Rd index 09bbb5d4..6778898a 100644 --- a/man/CategoricalVariable.Rd +++ b/man/CategoricalVariable.Rd @@ -17,6 +17,7 @@ if possible because certain operations will be faster. \item \href{#method-CategoricalVariable-get_index_of}{\code{CategoricalVariable$get_index_of()}} \item \href{#method-CategoricalVariable-get_size_of}{\code{CategoricalVariable$get_size_of()}} \item \href{#method-CategoricalVariable-get_categories}{\code{CategoricalVariable$get_categories()}} +\item \href{#method-CategoricalVariable-get_values}{\code{CategoricalVariable$get_values()}} \item \href{#method-CategoricalVariable-queue_update}{\code{CategoricalVariable$queue_update()}} \item \href{#method-CategoricalVariable-queue_extend}{\code{CategoricalVariable$queue_extend()}} \item \href{#method-CategoricalVariable-queue_shrink}{\code{CategoricalVariable$queue_shrink()}} @@ -94,6 +95,23 @@ unordered storage type. \if{html}{\out{
}}\preformatted{CategoricalVariable$get_categories()}\if{html}{\out{
}} } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-CategoricalVariable-get_values}{}}} +\subsection{Method \code{get_values()}}{ +return the value of the variable for the given individuals +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{CategoricalVariable$get_values(index = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{index}}{the indices of individuals whose categories will be returned} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/IntegerVariable.Rd b/man/IntegerVariable.Rd index 1215f6af..fcc2778a 100644 --- a/man/IntegerVariable.Rd +++ b/man/IntegerVariable.Rd @@ -15,6 +15,7 @@ household or age bin. \itemize{ \item \href{#method-IntegerVariable-new}{\code{IntegerVariable$new()}} \item \href{#method-IntegerVariable-get_values}{\code{IntegerVariable$get_values()}} +\item \href{#method-IntegerVariable-get_modulo_differences}{\code{IntegerVariable$get_modulo_differences()}} \item \href{#method-IntegerVariable-get_index_of}{\code{IntegerVariable$get_index_of()}} \item \href{#method-IntegerVariable-get_size_of}{\code{IntegerVariable$get_size_of()}} \item \href{#method-IntegerVariable-queue_update}{\code{IntegerVariable$queue_update()}} @@ -65,6 +66,27 @@ or integer vector, return values of those individuals.} } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-IntegerVariable-get_modulo_differences}{}}} +\subsection{Method \code{get_modulo_differences()}}{ +Return a vector of individuals with 0 modulo difference from input value +and the distance being compared +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{IntegerVariable$get_modulo_differences(value, difference)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{value}}{the value to check} + +\item{\code{difference}}{the difference to check, e.g. difference = 2 checks whether the +difference is even} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-IntegerVariable-get_index_of}{}}} \subsection{Method \code{get_index_of()}}{ diff --git a/man/bitset_count_and.Rd b/man/bitset_count_and.Rd new file mode 100644 index 00000000..58165b69 --- /dev/null +++ b/man/bitset_count_and.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bitset.R +\name{bitset_count_and} +\alias{bitset_count_and} +\title{Count bitset and} +\usage{ +bitset_count_and(a, b) +} +\arguments{ +\item{a}{a \code{\link{Bitset}}} + +\item{b}{another \code{\link{Bitset}}} +} +\description{ +This non-modifying function returns the number of intersecting +elements between two bitsets \code{a} and \code{b}. This should be faster than +writing \code{a$copy()$and(b)$size()} as it avoids the memory allocations of $copy(). +} diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 1c5e23da..63a7f8cd 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -237,6 +237,18 @@ BEGIN_RCPP return R_NilValue; END_RCPP } +// bitset_count_and_cpp +size_t bitset_count_and_cpp(const Rcpp::XPtr a, const Rcpp::XPtr b); +RcppExport SEXP _individual_bitset_count_and_cpp(SEXP aSEXP, SEXP bSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const Rcpp::XPtr >::type a(aSEXP); + Rcpp::traits::input_parameter< const Rcpp::XPtr >::type b(bSEXP); + rcpp_result_gen = Rcpp::wrap(bitset_count_and_cpp(a, b)); + return rcpp_result_gen; +END_RCPP +} // create_categorical_variable Rcpp::XPtr create_categorical_variable(const std::vector& categories, const std::vector& values); RcppExport SEXP _individual_create_categorical_variable(SEXP categoriesSEXP, SEXP valuesSEXP) { @@ -362,6 +374,29 @@ BEGIN_RCPP return R_NilValue; END_RCPP } +// categorical_variable_get_values +std::vector categorical_variable_get_values(Rcpp::XPtr variable); +RcppExport SEXP _individual_categorical_variable_get_values(SEXP variableSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::XPtr >::type variable(variableSEXP); + rcpp_result_gen = Rcpp::wrap(categorical_variable_get_values(variable)); + return rcpp_result_gen; +END_RCPP +} +// categorical_variable_get_values_with_index +std::vector categorical_variable_get_values_with_index(Rcpp::XPtr variable, std::vector& index); +RcppExport SEXP _individual_categorical_variable_get_values_with_index(SEXP variableSEXP, SEXP indexSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::XPtr >::type variable(variableSEXP); + Rcpp::traits::input_parameter< std::vector& >::type index(indexSEXP); + rcpp_result_gen = Rcpp::wrap(categorical_variable_get_values_with_index(variable, index)); + return rcpp_result_gen; +END_RCPP +} // dummy void dummy(); static SEXP _individual_dummy_try() { @@ -854,6 +889,19 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// integer_variable_get_modulo_differences +individual_index_t integer_variable_get_modulo_differences(Rcpp::XPtr variable, const int value, const int difference); +RcppExport SEXP _individual_integer_variable_get_modulo_differences(SEXP variableSEXP, SEXP valueSEXP, SEXP differenceSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::XPtr >::type variable(variableSEXP); + Rcpp::traits::input_parameter< const int >::type value(valueSEXP); + Rcpp::traits::input_parameter< const int >::type difference(differenceSEXP); + rcpp_result_gen = Rcpp::wrap(integer_variable_get_modulo_differences(variable, value, difference)); + return rcpp_result_gen; +END_RCPP +} // integer_variable_get_values_at_index std::vector integer_variable_get_values_at_index(Rcpp::XPtr variable, Rcpp::XPtr index); RcppExport SEXP _individual_integer_variable_get_values_at_index(SEXP variableSEXP, SEXP indexSEXP) { @@ -1497,6 +1545,7 @@ static const R_CallMethodDef CallEntries[] = { {"_individual_filter_bitset_bitset", (DL_FUNC) &_individual_filter_bitset_bitset, 2}, {"_individual_filter_bitset_logical", (DL_FUNC) &_individual_filter_bitset_logical, 2}, {"_individual_bitset_choose", (DL_FUNC) &_individual_bitset_choose, 2}, + {"_individual_bitset_count_and_cpp", (DL_FUNC) &_individual_bitset_count_and_cpp, 2}, {"_individual_create_categorical_variable", (DL_FUNC) &_individual_create_categorical_variable, 2}, {"_individual_categorical_variable_get_size", (DL_FUNC) &_individual_categorical_variable_get_size, 1}, {"_individual_categorical_variable_queue_update", (DL_FUNC) &_individual_categorical_variable_queue_update, 3}, @@ -1508,6 +1557,8 @@ static const R_CallMethodDef CallEntries[] = { {"_individual_categorical_variable_queue_extend", (DL_FUNC) &_individual_categorical_variable_queue_extend, 2}, {"_individual_categorical_variable_queue_shrink", (DL_FUNC) &_individual_categorical_variable_queue_shrink, 2}, {"_individual_categorical_variable_queue_shrink_bitset", (DL_FUNC) &_individual_categorical_variable_queue_shrink_bitset, 2}, + {"_individual_categorical_variable_get_values", (DL_FUNC) &_individual_categorical_variable_get_values, 1}, + {"_individual_categorical_variable_get_values_with_index", (DL_FUNC) &_individual_categorical_variable_get_values_with_index, 2}, {"_individual_dummy", (DL_FUNC) &_individual_dummy, 0}, {"_individual_create_double_variable", (DL_FUNC) &_individual_create_double_variable, 1}, {"_individual_double_variable_get_values", (DL_FUNC) &_individual_double_variable_get_values, 1}, @@ -1550,6 +1601,7 @@ static const R_CallMethodDef CallEntries[] = { {"_individual_process_targeted_listener", (DL_FUNC) &_individual_process_targeted_listener, 3}, {"_individual_create_integer_variable", (DL_FUNC) &_individual_create_integer_variable, 1}, {"_individual_integer_variable_get_values", (DL_FUNC) &_individual_integer_variable_get_values, 1}, + {"_individual_integer_variable_get_modulo_differences", (DL_FUNC) &_individual_integer_variable_get_modulo_differences, 3}, {"_individual_integer_variable_get_values_at_index", (DL_FUNC) &_individual_integer_variable_get_values_at_index, 2}, {"_individual_integer_variable_get_values_at_index_vector", (DL_FUNC) &_individual_integer_variable_get_values_at_index_vector, 2}, {"_individual_integer_variable_get_index_of_set_vector", (DL_FUNC) &_individual_integer_variable_get_index_of_set_vector, 2}, diff --git a/src/bitset.cpp b/src/bitset.cpp index aec4f9b7..a539c7d9 100644 --- a/src/bitset.cpp +++ b/src/bitset.cpp @@ -203,3 +203,11 @@ void bitset_choose( ) { bitset_choose_internal(*b, k); } + +//[[Rcpp::export]] +size_t bitset_count_and_cpp( + const Rcpp::XPtr a, + const Rcpp::XPtr b +) { + return a->count_and(*b); +} diff --git a/src/categorical_variable.cpp b/src/categorical_variable.cpp index f8c99fa0..5ad2ba0d 100644 --- a/src/categorical_variable.cpp +++ b/src/categorical_variable.cpp @@ -103,3 +103,22 @@ void categorical_variable_queue_shrink_bitset( ) { variable->queue_shrink(*index); } + +//[[Rcpp::export]] +std::vector categorical_variable_get_values( + Rcpp::XPtr variable + ) { + std::vector results; + results = variable->get_values(); + return results; +} +//[[Rcpp::export]] +std::vector categorical_variable_get_values_with_index( + Rcpp::XPtr variable, + std::vector& index + ) { + decrement(index); + std::vector results; + results = variable->get_values(index); + return results; +} \ No newline at end of file diff --git a/src/integer_variable.cpp b/src/integer_variable.cpp index b878520c..90c362a1 100644 --- a/src/integer_variable.cpp +++ b/src/integer_variable.cpp @@ -26,6 +26,15 @@ const std::vector& integer_variable_get_values( return variable->get_values(); } +//[[Rcpp::export]] +individual_index_t integer_variable_get_modulo_differences( + Rcpp::XPtr variable, + const int value, + const int difference +) { + return variable->get_modulo_differences(value, difference); +} + //[[Rcpp::export]] std::vector integer_variable_get_values_at_index( Rcpp::XPtr variable, diff --git a/tests/performance/benchmark.sh b/tests/performance/benchmark.sh deleted file mode 100644 index 87935502..00000000 --- a/tests/performance/benchmark.sh +++ /dev/null @@ -1,2 +0,0 @@ -R -e "library('remotes'); install_local()" -/usr/bin/time -v Rscript tests/performance/big_deterministic.R diff --git a/tests/testthat/test-bitset.R b/tests/testthat/test-bitset.R index 888bdce8..b5f6a089 100644 --- a/tests/testthat/test-bitset.R +++ b/tests/testthat/test-bitset.R @@ -438,3 +438,41 @@ test_that("bitset is not equal to other types", { a$insert(c(1,4,5)) expect_equal(all.equal(a, c(1,4,5)), "'current' is not a Bitset") }) + +test_that("bitset_count_and can return the the count of overlapping betsets", { + a <- Bitset$new(10)$insert(c(1,4,5)) + b <- Bitset$new(10)$insert(c(4,6,9)) + c <- Bitset$new(10)$insert(c(4,5,9)) + d <- Bitset$new(10)$insert(c(1,4,5,9)) + expect_equal(bitset_count_and(a, b), 1) + expect_equal(bitset_count_and(a, c), 2) + expect_equal(bitset_count_and(a, d), 3) +}) + +test_that("bitset_count_and returns 0 for non-overlapping betsets", { + a <- Bitset$new(10)$insert(c(1,4,5)) + b <- Bitset$new(10)$insert(c(2,6,9)) + expect_equal(bitset_count_and(a, b), 0) +}) + +test_that("bitset_count_and doesn't mutate", { + a <- Bitset$new(10)$insert(c(1,4,5)) + b <- Bitset$new(10)$insert(c(4,6,9)) + c <- a$copy() + d <- b$copy() + bitset_count_and(a, b) + expect_equal(a, c) + expect_equal(b, d) +}) + +test_that("bitset_count_and doesn't work for differing sizes", { + a <- Bitset$new(10)$insert(c(1,4,5)) + b <- Bitset$new(15)$insert(c(4,6,9)) + c <- a$copy() + d <- b$copy() + expect_error( + bitset_count_and(a, b), + 'Incompatible bitmap sizes' + ) +}) + diff --git a/tests/testthat/test-categoricalvariable-resize.R b/tests/testthat/test-categoricalvariable-resize.R index 3b988bcc..212b7d08 100644 --- a/tests/testthat/test-categoricalvariable-resize.R +++ b/tests/testthat/test-categoricalvariable-resize.R @@ -1,62 +1,72 @@ -SIR <- c('S', 'I', 'R') - -test_that("CategoricalVariable extending variables returns the new values", { - x <- CategoricalVariable$new(SIR, rep('S', 10)) - expect_equal(x$get_index_of('S')$to_vector(), 1:10) - x$queue_extend(values = c('S', 'I', 'R')) - x$.resize() - expect_equal(x$get_index_of('S')$to_vector(), 1:11) - expect_equal(x$get_index_of('I')$to_vector(), 12) - expect_equal(x$get_index_of('R')$to_vector(), 13) -}) - -test_that("CategoricalVariable shrinking variables removes values (bitset)", { - x <- CategoricalVariable$new(SIR, rep('S', 10)) - x$queue_shrink(index = Bitset$new(10)$insert(1:5)) - x$.resize() - expect_equal(x$get_index_of('S')$to_vector(), 1:5) -}) - -test_that("CategoricalVariable shrinking variables removes values (vector)", { - x <- CategoricalVariable$new(SIR, rep('S', 10)) - x$queue_shrink(index = 6:10) - x$.resize() - expect_equal(x$get_index_of('S')$to_vector(), 1:5) -}) - -test_that("CategoricalVariable resizing variables returns the correct size", { - x <- CategoricalVariable$new(SIR, rep('S', 10)) - expect_equal(x$size(), 10) - x$queue_extend(values = rep('S', 10)) - x$queue_shrink(index = 5:10) - x$.resize() - expect_equal(x$size(), 14) -}) - - -test_that("CategoricalVariable shrinks are combined", { - x <- CategoricalVariable$new(SIR, rep('S', 10)) - x$queue_shrink(index = 1:5) - x$queue_shrink(index = 3:8) - x$.resize() - expect_equal(x$get_index_of('S')$to_vector(), 1:2) -}) - -test_that("CategoricalVariable shrinks are applied before extentions", { - x <- CategoricalVariable$new(SIR, rep('S', 10)) - x$queue_shrink(index = 5:10) - x$queue_extend(values = rep('I', 10)) - x$queue_shrink(index = 1:5) - x$queue_extend(values = rep('R', 10)) - x$.resize() - expect_equal(x$get_index_of('S')$to_vector(), double(0)) - expect_equal(x$get_index_of('I')$to_vector(), 1:10) - expect_equal(x$get_index_of('R')$to_vector(), 11:20) -}) - -test_that("CategoricalVariable invalid shrinking operations error at queue time", { - x <- CategoricalVariable$new(SIR, rep('S', 10)) - expect_error(x$queue_shrink(index = 1:20)) - expect_error(x$queue_shrink(index = -1:5)) - expect_error(x$queue_shrink(index = Bitset$new(size + 1)$insert(1:20))) -}) +SIR <- c('S', 'I', 'R') + +test_that("CategoricalVariable extending variables returns the new values", { + x <- CategoricalVariable$new(SIR, rep('S', 10)) + expect_equal(x$get_index_of('S')$to_vector(), 1:10) + x$queue_extend(values = c('S', 'I', 'R')) + x$.resize() + expect_equal(x$get_index_of('S')$to_vector(), 1:11) + expect_equal(x$get_index_of('I')$to_vector(), 12) + expect_equal(x$get_index_of('R')$to_vector(), 13) +}) + +test_that("CategoricalVariables returns correct values after resize", { + categories = c('S', 'S', 'R', 'I') + + # standard case + x <- CategoricalVariable$new(SIR, categories) + x$queue_extend(values = rep('I', 2)) + x$.resize() + expect_equal(x$get_values(seq(1:length(c(categories, rep('I', 2))))), c(categories, rep('I', 2))) +}) + +test_that("CategoricalVariable shrinking variables removes values (bitset)", { + x <- CategoricalVariable$new(SIR, rep('S', 10)) + x$queue_shrink(index = Bitset$new(10)$insert(1:5)) + x$.resize() + expect_equal(x$get_index_of('S')$to_vector(), 1:5) +}) + +test_that("CategoricalVariable shrinking variables removes values (vector)", { + x <- CategoricalVariable$new(SIR, rep('S', 10)) + x$queue_shrink(index = 6:10) + x$.resize() + expect_equal(x$get_index_of('S')$to_vector(), 1:5) +}) + +test_that("CategoricalVariable resizing variables returns the correct size", { + x <- CategoricalVariable$new(SIR, rep('S', 10)) + expect_equal(x$size(), 10) + x$queue_extend(values = rep('S', 10)) + x$queue_shrink(index = 5:10) + x$.resize() + expect_equal(x$size(), 14) +}) + + +test_that("CategoricalVariable shrinks are combined", { + x <- CategoricalVariable$new(SIR, rep('S', 10)) + x$queue_shrink(index = 1:5) + x$queue_shrink(index = 3:8) + x$.resize() + expect_equal(x$get_index_of('S')$to_vector(), 1:2) +}) + +test_that("CategoricalVariable shrinks are applied before extentions", { + x <- CategoricalVariable$new(SIR, rep('S', 10)) + x$queue_shrink(index = 5:10) + x$queue_extend(values = rep('I', 10)) + x$queue_shrink(index = 1:5) + x$queue_extend(values = rep('R', 10)) + x$.resize() + expect_equal(x$get_index_of('S')$to_vector(), double(0)) + expect_equal(x$get_index_of('I')$to_vector(), 1:10) + expect_equal(x$get_index_of('R')$to_vector(), 11:20) +}) + +test_that("CategoricalVariable invalid shrinking operations error at queue time", { + x <- CategoricalVariable$new(SIR, rep('S', 10)) + expect_error(x$queue_shrink(index = 1:20)) + expect_error(x$queue_shrink(index = -1:5)) + expect_error(x$queue_shrink(index = Bitset$new(size + 1)$insert(1:20))) +}) diff --git a/tests/testthat/test-categoricalvariable.R b/tests/testthat/test-categoricalvariable.R index d748076c..867bb4a6 100644 --- a/tests/testthat/test-categoricalvariable.R +++ b/tests/testthat/test-categoricalvariable.R @@ -1,103 +1,126 @@ -SIR <- c('S', 'I', 'R') - -test_that("Creating CategoricalVariables errors with bad input", { - expect_error(CategoricalVariable$new(NULL, NULL)) - expect_error(CategoricalVariable$new(NaN, NaN)) - expect_error(CategoricalVariable$new(NA, NA)) - expect_error(CategoricalVariable$new(categories = LETTERS[1:2], initial_values = letters[1:2])) - expect_error(CategoricalVariable$new(categories = character(0), initial_values = letters[1:2])) -}) - -test_that("CategoricalVariable get index works returns correct values", { - size <- 10 - state <- CategoricalVariable$new(SIR, rep('S', size)) - expect_setequal(state$get_index_of('S')$to_vector(), seq(10)) - - state <- CategoricalVariable$new( - SIR, - c(rep('S', 10), rep('I', 100), rep('R', 20)) - ) - - expect_setequal( - state$get_index_of('S')$to_vector(), - seq(10) - ) - - expect_setequal( - state$get_index_of(c('S', 'R'))$to_vector(), - c(seq(10), seq(20) + 110) - ) - - expect_setequal( - state$get_index_of(c('S'))$to_vector(), - seq(10) - ) - -}) - -test_that("CategoricalVariable get index errors with incorrect input", { - size <- 10 - state <- CategoricalVariable$new(SIR, rep('S', size)) - - expect_error(state$get_index_of(values = 'A')) - expect_error(state$get_index_of(values = c('S', 'A'))) - expect_error(state$get_index_of(values = LETTERS[1:3])) - expect_error(state$get_index_of(values = integer(0))) - expect_error(state$get_index_of(values = NULL)) - expect_error(state$get_index_of(values = NA)) - expect_error(state$get_index_of(values = NaN)) -}) - -test_that("CategoricalVariable get size of categories works returns correct values", { - size <- 10 - state <- CategoricalVariable$new(SIR, rep('S', size)) - expect_setequal(state$get_size_of('S'), size) - - state <- CategoricalVariable$new( - SIR, - c(rep('S', 10), rep('I', 100), rep('R', 20)) - ) - - expect_equal(state$get_size_of(c('S', 'R')), 30) - expect_equal(state$get_size_of(c('S', 'I')), 110) - expect_equal(state$get_size_of(c('S')), 10) - -}) - -test_that("CategoricalVariable get size of categories errors with incorrect input", { - size <- 10 - state <- CategoricalVariable$new(SIR, rep('S', size)) - - expect_error(state$get_size_of(values = 'A')) - expect_error(state$get_size_of(values = c('S', 'A'))) - expect_error(state$get_size_of(values = LETTERS[1:3])) - expect_error(state$get_size_of(values = integer(0))) - expect_error(state$get_size_of(values = NULL)) - expect_error(state$get_size_of(values = NA)) - expect_error(state$get_size_of(values = NaN)) -}) - -test_that("CategoricalVariables get categories works", { - size <- 10 - state <- CategoricalVariable$new(SIR, rep('S', size)) - expect_length(setdiff(state$get_categories(), SIR), 0) -}) - -test_that("CategoricalVariables supports checkpoint and restore", { - size <- 10 - - old_variable <- CategoricalVariable$new(SIR, rep('S', size)) - old_variable$queue_update('I', c(1, 3)) - old_variable$queue_update('R', c(2, 7)) - old_variable$.update() - - state <- old_variable$save_state() - - new_variable <- CategoricalVariable$new(SIR, rep('S', size)) - new_variable$restore_state(1, state) - - expect_equal(new_variable$get_index_of('S')$to_vector(), c(4,5,6,8,9,10)) - expect_equal(new_variable$get_index_of('I')$to_vector(), c(1,3)) - expect_equal(new_variable$get_index_of('R')$to_vector(), c(2,7)) - expect_equal(new_variable$save_state(), state) -}) +SIR <- c('S', 'I', 'R') + +test_that("Creating CategoricalVariables errors with bad input", { + expect_error(CategoricalVariable$new(NULL, NULL)) + expect_error(CategoricalVariable$new(NaN, NaN)) + expect_error(CategoricalVariable$new(NA, NA)) + expect_error(CategoricalVariable$new(categories = LETTERS[1:2], initial_values = letters[1:2])) + expect_error(CategoricalVariable$new(categories = character(0), initial_values = letters[1:2])) +}) + +test_that("CategoricalVariables returns correct values", { + categories = c('S', 'S', 'R', 'I') + + # standard case + variable <- CategoricalVariable$new(SIR, categories) + expect_equal(variable$get_values(seq(1,4)), categories) + expect_equal(variable$get_values(c(2,4)), c(categories[c(2,4)])) + + # empty case + variable <- CategoricalVariable$new(SIR, character(0)) + expect_equal(variable$get_values() , character(0)) +}) + +test_that("CategoricalVariables returns correct values after update", { + categories = c('S', 'S', 'R', 'I') + + # standard case + variable <- CategoricalVariable$new(SIR, categories) + variable$queue_update('I', 1) + variable$.update() + expect_equal(variable$get_values(seq(1,4)), c('I', 'S', 'R', 'I')) +}) + +test_that("CategoricalVariable get index works returns correct values", { + size <- 10 + state <- CategoricalVariable$new(SIR, rep('S', size)) + expect_setequal(state$get_index_of('S')$to_vector(), seq(10)) + + state <- CategoricalVariable$new( + SIR, + c(rep('S', 10), rep('I', 100), rep('R', 20)) + ) + + expect_setequal( + state$get_index_of('S')$to_vector(), + seq(10) + ) + + expect_setequal( + state$get_index_of(c('S', 'R'))$to_vector(), + c(seq(10), seq(20) + 110) + ) + + expect_setequal( + state$get_index_of(c('S'))$to_vector(), + seq(10) + ) + +}) + +test_that("CategoricalVariable get index errors with incorrect input", { + size <- 10 + state <- CategoricalVariable$new(SIR, rep('S', size)) + + expect_error(state$get_index_of(values = 'A')) + expect_error(state$get_index_of(values = c('S', 'A'))) + expect_error(state$get_index_of(values = LETTERS[1:3])) + expect_error(state$get_index_of(values = integer(0))) + expect_error(state$get_index_of(values = NULL)) + expect_error(state$get_index_of(values = NA)) + expect_error(state$get_index_of(values = NaN)) +}) + +test_that("CategoricalVariable get size of categories works returns correct values", { + size <- 10 + state <- CategoricalVariable$new(SIR, rep('S', size)) + expect_setequal(state$get_size_of('S'), size) + + state <- CategoricalVariable$new( + SIR, + c(rep('S', 10), rep('I', 100), rep('R', 20)) + ) + + expect_equal(state$get_size_of(c('S', 'R')), 30) + expect_equal(state$get_size_of(c('S', 'I')), 110) + expect_equal(state$get_size_of(c('S')), 10) + +}) + +test_that("CategoricalVariable get size of categories errors with incorrect input", { + size <- 10 + state <- CategoricalVariable$new(SIR, rep('S', size)) + + expect_error(state$get_size_of(values = 'A')) + expect_error(state$get_size_of(values = c('S', 'A'))) + expect_error(state$get_size_of(values = LETTERS[1:3])) + expect_error(state$get_size_of(values = integer(0))) + expect_error(state$get_size_of(values = NULL)) + expect_error(state$get_size_of(values = NA)) + expect_error(state$get_size_of(values = NaN)) +}) + +test_that("CategoricalVariables get categories works", { + size <- 10 + state <- CategoricalVariable$new(SIR, rep('S', size)) + expect_length(setdiff(state$get_categories(), SIR), 0) +}) + +test_that("CategoricalVariables supports checkpoint and restore", { + size <- 10 + + old_variable <- CategoricalVariable$new(SIR, rep('S', size)) + old_variable$queue_update('I', c(1, 3)) + old_variable$queue_update('R', c(2, 7)) + old_variable$.update() + + state <- old_variable$save_state() + + new_variable <- CategoricalVariable$new(SIR, rep('S', size)) + new_variable$restore_state(1, state) + + expect_equal(new_variable$get_index_of('S')$to_vector(), c(4,5,6,8,9,10)) + expect_equal(new_variable$get_index_of('I')$to_vector(), c(1,3)) + expect_equal(new_variable$get_index_of('R')$to_vector(), c(2,7)) + expect_equal(new_variable$save_state(), state) +}) diff --git a/tests/testthat/test-integervariable.R b/tests/testthat/test-integervariable.R index d79e9943..5aea6c59 100644 --- a/tests/testthat/test-integervariable.R +++ b/tests/testthat/test-integervariable.R @@ -1,207 +1,230 @@ -test_that("Creating IntegerVariables errors with bad input", { - expect_error(IntegerVariable$new(NULL)) - expect_error(IntegerVariable$new(NaN)) - expect_error(IntegerVariable$new(c(1,NaN))) - expect_error(IntegerVariable$new(NA)) - expect_error(IntegerVariable$new(c(1,NA))) - expect_error(IntegerVariable$new(Inf)) - expect_error(IntegerVariable$new(c(1,Inf))) - expect_error(IntegerVariable$new(-Inf)) - expect_error(IntegerVariable$new(c(1,-Inf))) - expect_error(IntegerVariable$new("1")) -}) - -test_that("IntegerVariable get values returns correct values without index", { - size <- 10 - variable <- IntegerVariable$new(seq_len(size)) - expect_equal(variable$get_values(), 1:10) - - variable <- IntegerVariable$new(seq_len(size) + 10) - expect_equal(variable$get_values(), (1:10) + 10) - - variable <- IntegerVariable$new(seq_len(size)) - expect_equal(variable$get_values(c(1, 1, 2, 2)), c(1, 1, 2, 2)) -}) - -test_that("IntegerVariable get values returns correct values with vector index", { - size <- 10 - variable <- IntegerVariable$new(seq_len(size)) - expect_equal(variable$get_values(NULL), 1:10) - - variable <- IntegerVariable$new(seq_len(size) + 10) - expect_equal(variable$get_values(5:10), 15:20) -}) - -test_that("IntegerVariable get values returns correct values with bitset index", { - size <- 10 - variable <- IntegerVariable$new(seq_len(size) + 10) - expect_equal(variable$get_values(Bitset$new(size = size)$insert(5:10)), 15:20) -}) - -test_that("IntegerVariable get values fails with incorrect index", { - variable <- IntegerVariable$new(initial_values = 1:100) - b <- Bitset$new(1000) - expect_error(variable$get_values(b)) - expect_error(variable$get_values(b$insert(90:110))) - expect_error(variable$get_values(90:110)) - expect_error(variable$get_values(-5:2)) - expect_error(variable$get_values(NaN)) - expect_error(variable$get_values(NA)) - expect_error(variable$get_values(Inf)) - expect_error(variable$get_values("10")) -}) - -test_that("IntegerVariable get index of set works correctly", { - variable <- IntegerVariable$new(5:10) - - indices <- variable$get_index_of(set = 6:8) - expect_equal(indices$to_vector(), 2:4) - - indices <- variable$get_index_of(set = 10) - expect_equal(indices$to_vector(), 6) - - indices <- variable$get_index_of(set = 1e3:1.001e3) - expect_equal(indices$size(), 0) - - indices <- variable$get_index_of(set = -5) - expect_equal(indices$size(), 0) - - indices <- variable$get_index_of(set = integer(0)) - expect_equal(indices$size(), 0) - - indices <- variable$get_index_of(set = numeric(0)) - expect_equal(indices$size(), 0) - - variable <- IntegerVariable$new(-10:10) - indices <- variable$get_index_of(set = c(-2,-1,1,2)) - expect_equal(indices$to_vector(), c(9, 10, 12, 13)) -}) - -test_that("IntegerVariable get index of set fails with incorrect set", { - variable <- IntegerVariable$new(1:10) - expect_error(variable$get_index_of(set = Inf)) - expect_error(variable$get_index_of(set = -Inf)) - expect_error(variable$get_index_of(set = NULL)) - expect_error(variable$get_index_of(set = NA)) - expect_error(variable$get_index_of(set = NaN)) - expect_error(variable$get_index_of(set = "5")) -}) - - -test_that("IntegerVariable get index of bounds [a,b] works correctly", { - variable <- IntegerVariable$new(5:10) - - indices <- variable$get_index_of(a = 6, b = 8) - expect_equal(indices$to_vector(), 2:4) - - indices <- variable$get_index_of(a = 7, b = 7) - expect_equal(indices$to_vector(), 3) - - indices <- variable$get_index_of(a = 1e3, b = 1.001e3) - expect_length(indices$to_vector(), 0) -}) - -test_that("IntegerVariable get index of bounds [a,b] fails with incorrect bounds", { - variable <- IntegerVariable$new(5:10) - - expect_error(variable$get_index_of(a = a, b = NULL)) - expect_error(variable$get_index_of(a = a, b = a - 10)) - expect_error(variable$get_index_of(a = a, b = NA)) - expect_error(variable$get_index_of(a = a, b = NaN)) - expect_error(variable$get_index_of(a = a, b = Inf)) - expect_error(variable$get_index_of(a = a, b = -Inf)) - - expect_error(variable$get_index_of(a = NULL, b = b)) - expect_error(variable$get_index_of(a = b + 10, b = b)) - expect_error(variable$get_index_of(a = NA, b = b)) - expect_error(variable$get_index_of(a = NaN, b = b)) - expect_error(variable$get_index_of(a = Inf, b = b)) - expect_error(variable$get_index_of(a = -Inf, b = b)) - - expect_error(variable$get_index_of(a = integer(0), b = b)) - expect_error(variable$get_index_of(a = numeric(0), b = b)) - - expect_error(variable$get_index_of(a = a, b = integer(0))) - expect_error(variable$get_index_of(a = a, b = integer(0))) - - expect_error(variable$get_index_of(a = integer(0), b = integer(0))) - expect_error(variable$get_index_of(a = numeric(0), b = numeric(0))) -}) - -test_that("IntegerVariable get size of set works correctly", { - variable <- IntegerVariable$new(-10:10) - set <- c(-2,-1,1,2) - expect_equal(variable$get_size_of(set = set), length(set)) - - expect_equal(variable$get_size_of(set = -20:-15), 0) - expect_equal(variable$get_size_of(set = 10), 1) - expect_equal(variable$get_size_of(set = numeric(0)), 0) - expect_equal(variable$get_size_of(set = integer(0)), 0) -}) - -test_that("IntegerVariable get size of set fails with incorrect input", { - variable <- IntegerVariable$new(-10:10) - expect_error(variable$get_size_of(set = NULL)) - expect_error(variable$get_size_of(set = NA)) - expect_error(variable$get_size_of(set = NaN)) - expect_error(variable$get_size_of(set = Inf)) - expect_error(variable$get_size_of(set = -Inf)) - expect_error(variable$get_size_of(set = "5")) -}) - -test_that("IntegerVariable get size of set in bounds [a,b] works correctly", { - variable <- IntegerVariable$new(-10:10) - expect_equal(variable$get_size_of(a = 5, b = 7), 3) - expect_equal(variable$get_size_of(a = 5, b = 5), 1) - expect_equal(variable$get_size_of(a = -10, b = -5), 6) - expect_equal(variable$get_size_of(a = -50, b = -40), 0) -}) - -test_that("IntegerVariable get size of set in bounds [a,b] fails with incorrect input", { - variable <- IntegerVariable$new(-10:10) - - expect_error(variable$get_size_of(a = a, b = NULL)) - expect_error(variable$get_size_of(a = a, b = a - 10)) - expect_error(variable$get_size_of(a = a, b = NA)) - expect_error(variable$get_size_of(a = a, b = NaN)) - expect_error(variable$get_size_of(a = a, b = Inf)) - expect_error(variable$get_size_of(a = a, b = -Inf)) - - expect_error(variable$get_size_of(a = NULL, b = b)) - expect_error(variable$get_size_of(a = b + 10, b = b)) - expect_error(variable$get_size_of(a = NA, b = b)) - expect_error(variable$get_size_of(a = NaN, b = b)) - expect_error(variable$get_size_of(a = Inf, b = b)) - expect_error(variable$get_size_of(a = -Inf, b = b)) - - expect_error(variable$get_size_of(a = integer(0), b = b)) - expect_error(variable$get_size_of(a = numeric(0), b = b)) - - expect_error(variable$get_size_of(a = a, b = integer(0))) - expect_error(variable$get_size_of(a = a, b = integer(0))) - - expect_error(variable$get_size_of(a = integer(0), b = integer(0))) - expect_error(variable$get_size_of(a = numeric(0), b = numeric(0))) -}) - -test_that("IntegerVariable get size and index of set in bounds [a,b] and set gives same answer for equal intervals", { - variable <- IntegerVariable$new(-10:10) - expect_equal(variable$get_size_of(a = 5, b = 7), variable$get_size_of(set = 5:7)) - expect_equal(variable$get_index_of(a = 5, b = 7)$to_vector(), variable$get_index_of(set = 5:7)$to_vector()) -}) - -test_that("IntegerVariable supports checkpoint and restore", { - size <- 10 - - old_variable <- IntegerVariable$new(rep(0, size)) - old_variable$queue_update(values = seq_len(size)) - old_variable$.update() - - state <- old_variable$save_state() - - new_variable <- IntegerVariable$new(rep(0, size)) - new_variable$restore_state(1, state) - - expect_equal(new_variable$get_values(), seq_len(size)) - expect_equal(new_variable$save_state(), state) -}) +test_that("Creating IntegerVariables errors with bad input", { + expect_error(IntegerVariable$new(NULL)) + expect_error(IntegerVariable$new(NaN)) + expect_error(IntegerVariable$new(c(1,NaN))) + expect_error(IntegerVariable$new(NA)) + expect_error(IntegerVariable$new(c(1,NA))) + expect_error(IntegerVariable$new(Inf)) + expect_error(IntegerVariable$new(c(1,Inf))) + expect_error(IntegerVariable$new(-Inf)) + expect_error(IntegerVariable$new(c(1,-Inf))) + expect_error(IntegerVariable$new("1")) +}) + +test_that("IntegerVariable get values returns correct values without index", { + size <- 10 + variable <- IntegerVariable$new(seq_len(size)) + expect_equal(variable$get_values(), 1:10) + + variable <- IntegerVariable$new(seq_len(size) + 10) + expect_equal(variable$get_values(), (1:10) + 10) + + variable <- IntegerVariable$new(seq_len(size)) + expect_equal(variable$get_values(c(1, 1, 2, 2)), c(1, 1, 2, 2)) +}) + +test_that("IntegerVariables returns correct modulo differences", { + size <- 10 + variable <- IntegerVariable$new(seq_len(size)) + vals <- variable$get_values() + x <- 3 + d <- 3 + expected_modulo_differences <- c() + ind <- 1 + for(i in seq_len(size)){ + val <- vals[i] + if ((val - x) %% d == 0){ + expected_modulo_differences[ind] <- i - 1 + ind <- ind + 1 + } + } + expect_equal(variable$get_modulo_differences(x, d), expected_modulo_differences) +}) + +test_that("IntegerVariables errors for invalid modulo differences", { + expect_error(variable$get_modulo_differences()) + expect_error(variable$get_modulo_differences("a", 1)) + expect_error(variable$get_modulo_differences(1, "1")) +}) +test_that("IntegerVariable get values returns correct values with vector index", { + size <- 10 + variable <- IntegerVariable$new(seq_len(size)) + expect_equal(variable$get_values(NULL), 1:10) + + variable <- IntegerVariable$new(seq_len(size) + 10) + expect_equal(variable$get_values(5:10), 15:20) +}) + +test_that("IntegerVariable get values returns correct values with bitset index", { + size <- 10 + variable <- IntegerVariable$new(seq_len(size) + 10) + expect_equal(variable$get_values(Bitset$new(size = size)$insert(5:10)), 15:20) +}) + +test_that("IntegerVariable get values fails with incorrect index", { + variable <- IntegerVariable$new(initial_values = 1:100) + b <- Bitset$new(1000) + expect_error(variable$get_values(b)) + expect_error(variable$get_values(b$insert(90:110))) + expect_error(variable$get_values(90:110)) + expect_error(variable$get_values(-5:2)) + expect_error(variable$get_values(NaN)) + expect_error(variable$get_values(NA)) + expect_error(variable$get_values(Inf)) + expect_error(variable$get_values("10")) +}) + +test_that("IntegerVariable get index of set works correctly", { + variable <- IntegerVariable$new(5:10) + + indices <- variable$get_index_of(set = 6:8) + expect_equal(indices$to_vector(), 2:4) + + indices <- variable$get_index_of(set = 10) + expect_equal(indices$to_vector(), 6) + + indices <- variable$get_index_of(set = 1e3:1.001e3) + expect_equal(indices$size(), 0) + + indices <- variable$get_index_of(set = -5) + expect_equal(indices$size(), 0) + + indices <- variable$get_index_of(set = integer(0)) + expect_equal(indices$size(), 0) + + indices <- variable$get_index_of(set = numeric(0)) + expect_equal(indices$size(), 0) + + variable <- IntegerVariable$new(-10:10) + indices <- variable$get_index_of(set = c(-2,-1,1,2)) + expect_equal(indices$to_vector(), c(9, 10, 12, 13)) +}) + +test_that("IntegerVariable get index of set fails with incorrect set", { + variable <- IntegerVariable$new(1:10) + expect_error(variable$get_index_of(set = Inf)) + expect_error(variable$get_index_of(set = -Inf)) + expect_error(variable$get_index_of(set = NULL)) + expect_error(variable$get_index_of(set = NA)) + expect_error(variable$get_index_of(set = NaN)) + expect_error(variable$get_index_of(set = "5")) +}) + + +test_that("IntegerVariable get index of bounds [a,b] works correctly", { + variable <- IntegerVariable$new(5:10) + + indices <- variable$get_index_of(a = 6, b = 8) + expect_equal(indices$to_vector(), 2:4) + + indices <- variable$get_index_of(a = 7, b = 7) + expect_equal(indices$to_vector(), 3) + + indices <- variable$get_index_of(a = 1e3, b = 1.001e3) + expect_length(indices$to_vector(), 0) +}) + +test_that("IntegerVariable get index of bounds [a,b] fails with incorrect bounds", { + variable <- IntegerVariable$new(5:10) + + expect_error(variable$get_index_of(a = a, b = NULL)) + expect_error(variable$get_index_of(a = a, b = a - 10)) + expect_error(variable$get_index_of(a = a, b = NA)) + expect_error(variable$get_index_of(a = a, b = NaN)) + expect_error(variable$get_index_of(a = a, b = Inf)) + expect_error(variable$get_index_of(a = a, b = -Inf)) + + expect_error(variable$get_index_of(a = NULL, b = b)) + expect_error(variable$get_index_of(a = b + 10, b = b)) + expect_error(variable$get_index_of(a = NA, b = b)) + expect_error(variable$get_index_of(a = NaN, b = b)) + expect_error(variable$get_index_of(a = Inf, b = b)) + expect_error(variable$get_index_of(a = -Inf, b = b)) + + expect_error(variable$get_index_of(a = integer(0), b = b)) + expect_error(variable$get_index_of(a = numeric(0), b = b)) + + expect_error(variable$get_index_of(a = a, b = integer(0))) + expect_error(variable$get_index_of(a = a, b = integer(0))) + + expect_error(variable$get_index_of(a = integer(0), b = integer(0))) + expect_error(variable$get_index_of(a = numeric(0), b = numeric(0))) +}) + +test_that("IntegerVariable get size of set works correctly", { + variable <- IntegerVariable$new(-10:10) + set <- c(-2,-1,1,2) + expect_equal(variable$get_size_of(set = set), length(set)) + + expect_equal(variable$get_size_of(set = -20:-15), 0) + expect_equal(variable$get_size_of(set = 10), 1) + expect_equal(variable$get_size_of(set = numeric(0)), 0) + expect_equal(variable$get_size_of(set = integer(0)), 0) +}) + +test_that("IntegerVariable get size of set fails with incorrect input", { + variable <- IntegerVariable$new(-10:10) + expect_error(variable$get_size_of(set = NULL)) + expect_error(variable$get_size_of(set = NA)) + expect_error(variable$get_size_of(set = NaN)) + expect_error(variable$get_size_of(set = Inf)) + expect_error(variable$get_size_of(set = -Inf)) + expect_error(variable$get_size_of(set = "5")) +}) + +test_that("IntegerVariable get size of set in bounds [a,b] works correctly", { + variable <- IntegerVariable$new(-10:10) + expect_equal(variable$get_size_of(a = 5, b = 7), 3) + expect_equal(variable$get_size_of(a = 5, b = 5), 1) + expect_equal(variable$get_size_of(a = -10, b = -5), 6) + expect_equal(variable$get_size_of(a = -50, b = -40), 0) +}) + +test_that("IntegerVariable get size of set in bounds [a,b] fails with incorrect input", { + variable <- IntegerVariable$new(-10:10) + + expect_error(variable$get_size_of(a = a, b = NULL)) + expect_error(variable$get_size_of(a = a, b = a - 10)) + expect_error(variable$get_size_of(a = a, b = NA)) + expect_error(variable$get_size_of(a = a, b = NaN)) + expect_error(variable$get_size_of(a = a, b = Inf)) + expect_error(variable$get_size_of(a = a, b = -Inf)) + + expect_error(variable$get_size_of(a = NULL, b = b)) + expect_error(variable$get_size_of(a = b + 10, b = b)) + expect_error(variable$get_size_of(a = NA, b = b)) + expect_error(variable$get_size_of(a = NaN, b = b)) + expect_error(variable$get_size_of(a = Inf, b = b)) + expect_error(variable$get_size_of(a = -Inf, b = b)) + + expect_error(variable$get_size_of(a = integer(0), b = b)) + expect_error(variable$get_size_of(a = numeric(0), b = b)) + + expect_error(variable$get_size_of(a = a, b = integer(0))) + expect_error(variable$get_size_of(a = a, b = integer(0))) + + expect_error(variable$get_size_of(a = integer(0), b = integer(0))) + expect_error(variable$get_size_of(a = numeric(0), b = numeric(0))) +}) + +test_that("IntegerVariable get size and index of set in bounds [a,b] and set gives same answer for equal intervals", { + variable <- IntegerVariable$new(-10:10) + expect_equal(variable$get_size_of(a = 5, b = 7), variable$get_size_of(set = 5:7)) + expect_equal(variable$get_index_of(a = 5, b = 7)$to_vector(), variable$get_index_of(set = 5:7)$to_vector()) +}) + +test_that("IntegerVariable supports checkpoint and restore", { + size <- 10 + + old_variable <- IntegerVariable$new(rep(0, size)) + old_variable$queue_update(values = seq_len(size)) + old_variable$.update() + + state <- old_variable$save_state() + + new_variable <- IntegerVariable$new(rep(0, size)) + new_variable$restore_state(1, state) + + expect_equal(new_variable$get_values(), seq_len(size)) + expect_equal(new_variable$save_state(), state) +}) diff --git a/vignettes/Contributing.Rmd b/vignettes/Contributing.Rmd index ed345ed1..2a562cf1 100644 --- a/vignettes/Contributing.Rmd +++ b/vignettes/Contributing.Rmd @@ -77,6 +77,10 @@ Our review process is based off of [RESIDE's PR review process](https://reside-i ## Microbenchmarks +We have R based benchmarks in tests/performance. Please add new benchmarks for performance critical code. + +Please note the google benchmarks are deprecated. The below instructions will not work since building requires including R and Rcpp. + We use [google benchmark](https://github.com/google/benchmark) for our microbenchmarks. You can compile and run the benchmarks like this: @@ -92,4 +96,4 @@ g++ *_benchmark.cpp -std=c++14 -lbenchmark -lpthread -o benchmark.out * More Variables * Speed optimisations (tests TBC) * CRAN - * Anything on the github issue board \ No newline at end of file + * Anything on the github issue board