diff --git a/DESCRIPTION b/DESCRIPTION index 333c4db..90ac842 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: epiworldR Type: Package Title: Fast Agent-Based Epi Models -Version: 0.6-0 +Version: 0.6-0.0 Authors@R: c( person(given="George", family="Vega Yon", role=c("aut","cre"), email="g.vegayon@gmail.com", comment = c(ORCID = "0000-0002-3171-0844")), diff --git a/NAMESPACE b/NAMESPACE index 85ad16a..4324c45 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -125,12 +125,22 @@ export(distribute_virus_set) export(entity) export(entity_add_agent) export(entity_get_agents) -export(get_accepted_params) -export(get_accepted_stats) export(get_agents) export(get_agents_data_ncols) export(get_agents_states) export(get_agents_tools) +export(get_all_accepted_kernel_scores) +export(get_all_accepted_params) +export(get_all_accepted_stats) +export(get_all_sample_acceptance) +export(get_all_sample_drawn_prob) +export(get_all_sample_kernel_scores) +export(get_all_sample_params) +export(get_all_sample_stats) +export(get_current_accepted_params) +export(get_current_accepted_stats) +export(get_current_proposed_params) +export(get_current_proposed_stats) export(get_entities) export(get_entity_name) export(get_entity_size) @@ -139,6 +149,7 @@ export(get_hist_tool) export(get_hist_total) export(get_hist_transition_matrix) export(get_hist_virus) +export(get_initial_params) export(get_mean_params) export(get_mean_stats) export(get_n_params) @@ -152,9 +163,9 @@ export(get_name_tool) export(get_name_virus) export(get_ndays) export(get_network) +export(get_observed_stats) export(get_param) export(get_reproductive_number) -export(get_sample_stats) export(get_state) export(get_states) export(get_today_total) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 4f533c4..1030a6d 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -220,82 +220,110 @@ use_kernel_fun_gaussian <- function(lfmcmc) { } #' @rdname LFMCMC -#' @param names Character vector of names. #' @returns -#' - `set_params_names`: The lfmcmc model with the parameter names added. +#' - `get_mean_params`: The param means for the given lfmcmc model. #' @export -set_params_names <- function(lfmcmc, names) { +get_mean_params <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - set_params_names_cpp(lfmcmc, names) - invisible(lfmcmc) + get_mean_params_cpp(lfmcmc) } #' @rdname LFMCMC #' @returns -#' - `set_stats_names`: The lfmcmc model with the stats names added. +#' - `get_mean_stats`: The stats means for the given lfmcmc model. #' @export -set_stats_names <- function(lfmcmc, names) { +get_mean_stats <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - set_stats_names_cpp(lfmcmc, names) - invisible(lfmcmc) + get_mean_stats_cpp(lfmcmc) } #' @rdname LFMCMC +#' @export #' @returns -#' - `get_mean_params`: The param means for the given lfmcmc model. +#' - The function `get_initial_params` returns the initial parameters +#' for the given LFMCMC model. +get_initial_params <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + get_initial_params_cpp(lfmcmc) + +} + +#' @rdname LFMCMC #' @export -get_mean_params <- function(lfmcmc) { +#' @returns +#' - The function `get_current_proposed_params` returns the proposed parameters +#' for the next LFMCMC sample. +get_current_proposed_params <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - get_mean_params_cpp(lfmcmc) + get_current_proposed_params_cpp(lfmcmc) } #' @rdname LFMCMC +#' @export #' @returns -#' - `get_mean_stats`: The stats means for the given lfmcmc model. +#' - The function `get_current_accepted_params` returns the most recently accepted +#' parameters (the current state of the LFMCMC) +get_current_accepted_params <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + get_current_accepted_params_cpp(lfmcmc) + +} + +#' @rdname LFMCMC #' @export -get_mean_stats <- function(lfmcmc) { +#' @returns +#' - The function `get_current_proposed_stats` returns the statistics +#' from the simulation run with the proposed parameters +get_current_proposed_stats <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - get_mean_stats_cpp(lfmcmc) + get_current_proposed_stats_cpp(lfmcmc) } #' @rdname LFMCMC -#' @param x LFMCMC model to print -#' @param ... Ignored -#' @param burnin Integer. Number of samples to discard as burnin before -#' computing the summary. #' @export -print.epiworld_lfmcmc <- function(x, burnin = 0, ...) { +#' @returns +#' - The function `get_current_accepted_stats` returns the statistics +#' from the most recently accepted parameters +get_current_accepted_stats <- function(lfmcmc) { - if (!is.numeric(burnin)) - stop("The 'burnin' argument must be an integer.") + stopifnot_lfmcmc(lfmcmc) + get_current_accepted_stats_cpp(lfmcmc) - if (burnin < 0) - stop("The 'burnin' argument must be a non-negative integer.") +} - print_lfmcmc_cpp(x, burnin = burnin) - invisible(x) +#' @rdname LFMCMC +#' @export +#' @returns +#' - The function `get_observed_stats` returns the statistics +#' for the observed data +get_observed_stats <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + get_observed_stats_cpp(lfmcmc) } #' @rdname LFMCMC #' @export #' @returns -#' - The function `get_accepted_params` returns a matrix of accepted +#' - The function `get_all_sample_params` returns a matrix of sample #' parameters for the given LFMCMC model. with the number of rows equal to the #' number of samples and the number of columns equal to the number of #' parameters. -get_accepted_params <- function(lfmcmc) { +get_all_sample_params <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - a_params <- get_accepted_params_cpp(lfmcmc) + a_params <- get_all_sample_params_cpp(lfmcmc) n_params <- get_n_params(lfmcmc) matrix( @@ -306,57 +334,126 @@ get_accepted_params <- function(lfmcmc) { } - -#' @rdname LFMCMC #' @export +#' @rdname LFMCMC #' @returns -#' - The function `get_accepted_stats` returns a matrix of accepted statistics +#' - The function `get_all_sample_stats` returns a matrix of statistics #' for the given LFMCMC model. with the number of rows equal to the number of #' samples and the number of columns equal to the number of statistics. -get_accepted_stats <- function(lfmcmc) { +get_all_sample_stats <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - a_stats <- get_accepted_stats_cpp(lfmcmc) + stats <- get_all_sample_stats_cpp(lfmcmc) n_stats <- get_n_stats(lfmcmc) matrix( - a_stats, + stats, ncol = n_stats, byrow = TRUE ) } +#' @rdname LFMCMC +#' @export +#' @returns +#' - The function `get_all_sample_acceptance` returns a vector of boolean flags +#' which indicate whether a given sample was accepted +get_all_sample_acceptance <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + get_all_sample_acceptance_cpp(lfmcmc) + +} + +#' @rdname LFMCMC +#' @export +#' @returns +#' - The function `get_all_sample_drawn_prob` returns a vector of drawn probabilities +#' for each sample +get_all_sample_drawn_prob <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + get_all_sample_drawn_prob_cpp(lfmcmc) + +} + +#' @rdname LFMCMC +#' @export +#' @returns +#' - The function `get_all_sample_kernel_scores` returns a vector of kernel scores for +#' each sample +get_all_sample_kernel_scores <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + get_all_sample_kernel_scores_cpp(lfmcmc) + +} + +#' @rdname LFMCMC #' @export +#' @returns +#' - The function `get_all_accepted_params` returns a matrix of accepted +#' parameters for the given LFMCMC model. with the number of rows equal to the +#' number of samples and the number of columns equal to the number of +#' parameters. +get_all_accepted_params <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + a_params <- get_all_accepted_params_cpp(lfmcmc) + n_params <- get_n_params(lfmcmc) + + matrix( + a_params, + ncol = n_params, + byrow = TRUE + ) + +} + + #' @rdname LFMCMC +#' @export #' @returns -#' - The function `get_sample_stats` returns a matrix of statistics +#' - The function `get_all_accepted_stats` returns a matrix of accepted statistics #' for the given LFMCMC model. with the number of rows equal to the number of #' samples and the number of columns equal to the number of statistics. -get_sample_stats <- function(lfmcmc) { +get_all_accepted_stats <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - stats <- get_sample_stats_cpp(lfmcmc) + a_stats <- get_all_accepted_stats_cpp(lfmcmc) n_stats <- get_n_stats(lfmcmc) matrix( - stats, + a_stats, ncol = n_stats, byrow = TRUE ) } +#' @rdname LFMCMC +#' @export +#' @returns +#' - The function `get_all_accepted_kernel_scores` returns a vector of kernel scores for +#' each accepted sample +get_all_accepted_kernel_scores <- function(lfmcmc) { + + stopifnot_lfmcmc(lfmcmc) + get_all_accepted_kernel_scores_cpp(lfmcmc) + +} + #' @export #' @rdname LFMCMC #' @returns -#' - The functions `get_n_params`, `get_n_stats`, and `get_n_samples` -#' return the number of parameters, statistics, and samples for the given +#' - The functions `get_n_samples`, `get_n_stats`, and `get_n_params` +#' return the number of samples, statistics, and parameters for the given #' LFMCMC model, respectively. -get_n_params <- function(lfmcmc) { +get_n_samples <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - get_n_params_cpp(lfmcmc) + get_n_samples_cpp(lfmcmc) } @@ -371,10 +468,10 @@ get_n_stats <- function(lfmcmc) { #' @export #' @rdname LFMCMC -get_n_samples <- function(lfmcmc) { +get_n_params <- function(lfmcmc) { stopifnot_lfmcmc(lfmcmc) - get_n_samples_cpp(lfmcmc) + get_n_params_cpp(lfmcmc) } @@ -396,3 +493,47 @@ verbose_off.epiworld_lfmcmc <- function(x) { verbose_on.epiworld_lfmcmc <- function(x) { invisible(verbose_on_lfmcmc_cpp(x)) } + +#' @rdname LFMCMC +#' @param names Character vector of names. +#' @returns +#' - `set_params_names`: The lfmcmc model with the parameter names added. +#' @export +set_params_names <- function(lfmcmc, names) { + + stopifnot_lfmcmc(lfmcmc) + set_params_names_cpp(lfmcmc, names) + invisible(lfmcmc) + +} + +#' @rdname LFMCMC +#' @returns +#' - `set_stats_names`: The lfmcmc model with the stats names added. +#' @export +set_stats_names <- function(lfmcmc, names) { + + stopifnot_lfmcmc(lfmcmc) + set_stats_names_cpp(lfmcmc, names) + invisible(lfmcmc) + +} + +#' @rdname LFMCMC +#' @param x LFMCMC model to print +#' @param ... Ignored +#' @param burnin Integer. Number of samples to discard as burnin before +#' computing the summary. +#' @export +print.epiworld_lfmcmc <- function(x, burnin = 0, ...) { + + if (!is.numeric(burnin)) + stop("The 'burnin' argument must be an integer.") + + if (burnin < 0) + stop("The 'burnin' argument must be a non-negative integer.") + + print_lfmcmc_cpp(x, burnin = burnin) + invisible(x) + +} diff --git a/R/cpp11.R b/R/cpp11.R index ad8f431..6817d4a 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -256,14 +256,6 @@ use_kernel_fun_gaussian_cpp <- function(lfmcmc) { .Call(`_epiworldR_use_kernel_fun_gaussian_cpp`, lfmcmc) } -set_params_names_cpp <- function(lfmcmc, names) { - .Call(`_epiworldR_set_params_names_cpp`, lfmcmc, names) -} - -set_stats_names_cpp <- function(lfmcmc, names) { - .Call(`_epiworldR_set_stats_names_cpp`, lfmcmc, names) -} - get_mean_params_cpp <- function(lfmcmc) { .Call(`_epiworldR_get_mean_params_cpp`, lfmcmc) } @@ -272,20 +264,60 @@ get_mean_stats_cpp <- function(lfmcmc) { .Call(`_epiworldR_get_mean_stats_cpp`, lfmcmc) } -print_lfmcmc_cpp <- function(lfmcmc, burnin) { - .Call(`_epiworldR_print_lfmcmc_cpp`, lfmcmc, burnin) +get_initial_params_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_initial_params_cpp`, lfmcmc) +} + +get_current_proposed_params_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_current_proposed_params_cpp`, lfmcmc) +} + +get_current_accepted_params_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_current_accepted_params_cpp`, lfmcmc) +} + +get_current_proposed_stats_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_current_proposed_stats_cpp`, lfmcmc) +} + +get_current_accepted_stats_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_current_accepted_stats_cpp`, lfmcmc) +} + +get_observed_stats_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_observed_stats_cpp`, lfmcmc) +} + +get_all_sample_params_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_sample_params_cpp`, lfmcmc) +} + +get_all_sample_stats_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_sample_stats_cpp`, lfmcmc) } -get_sample_stats_cpp <- function(lfmcmc) { - .Call(`_epiworldR_get_sample_stats_cpp`, lfmcmc) +get_all_sample_acceptance_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_sample_acceptance_cpp`, lfmcmc) } -get_accepted_params_cpp <- function(lfmcmc) { - .Call(`_epiworldR_get_accepted_params_cpp`, lfmcmc) +get_all_sample_drawn_prob_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_sample_drawn_prob_cpp`, lfmcmc) } -get_accepted_stats_cpp <- function(lfmcmc) { - .Call(`_epiworldR_get_accepted_stats_cpp`, lfmcmc) +get_all_sample_kernel_scores_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_sample_kernel_scores_cpp`, lfmcmc) +} + +get_all_accepted_params_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_accepted_params_cpp`, lfmcmc) +} + +get_all_accepted_stats_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_accepted_stats_cpp`, lfmcmc) +} + +get_all_accepted_kernel_scores_cpp <- function(lfmcmc) { + .Call(`_epiworldR_get_all_accepted_kernel_scores_cpp`, lfmcmc) } get_n_samples_cpp <- function(lfmcmc) { @@ -308,6 +340,18 @@ verbose_on_lfmcmc_cpp <- function(lfmcmc) { .Call(`_epiworldR_verbose_on_lfmcmc_cpp`, lfmcmc) } +set_params_names_cpp <- function(lfmcmc, names) { + .Call(`_epiworldR_set_params_names_cpp`, lfmcmc, names) +} + +set_stats_names_cpp <- function(lfmcmc, names) { + .Call(`_epiworldR_set_stats_names_cpp`, lfmcmc, names) +} + +print_lfmcmc_cpp <- function(lfmcmc, burnin) { + .Call(`_epiworldR_print_lfmcmc_cpp`, lfmcmc, burnin) +} + print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp index ace7b63..46146a9 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp @@ -141,21 +141,23 @@ class LFMCMC { epiworld_double m_epsilon; - std::vector< epiworld_double > m_initial_params; ///< Initial parameters - std::vector< epiworld_double > m_current_params; ///< Parameters for the current sample - std::vector< epiworld_double > m_previous_params; ///< Parameters from the previous sample + std::vector< epiworld_double > m_initial_params; ///< Initial parameters + std::vector< epiworld_double > m_current_proposed_params; ///< Proposed parameters for the next sample + std::vector< epiworld_double > m_current_accepted_params; ///< Most recently accepted parameters (current state of MCMC) + std::vector< epiworld_double > m_current_proposed_stats; ///< Statistics from simulation run with proposed parameters + std::vector< epiworld_double > m_current_accepted_stats; ///< Statistics from simulation run with most recently accepted params - std::vector< epiworld_double > m_observed_stats; ///< Observed statistics + std::vector< epiworld_double > m_observed_stats; ///< Observed statistics - std::vector< epiworld_double > m_sample_params; ///< Parameter samples - std::vector< epiworld_double > m_sample_stats; ///< Statistic samples - std::vector< bool > m_sample_acceptance; ///< Indicator if sample was accepted - std::vector< epiworld_double > m_sample_drawn_prob; ///< Drawn probabilities (runif()) for each sample - std::vector< epiworld_double > m_sample_kernel_scores; ///< Kernel scores for each sample + std::vector< epiworld_double > m_all_sample_params; ///< Parameter samples + std::vector< epiworld_double > m_all_sample_stats; ///< Statistic samples + std::vector< bool > m_all_sample_acceptance; ///< Indicator if sample was accepted + std::vector< epiworld_double > m_all_sample_drawn_prob; ///< Drawn probabilities (runif()) for each sample + std::vector< epiworld_double > m_all_sample_kernel_scores; ///< Kernel scores for each sample - std::vector< epiworld_double > m_accepted_params; ///< Posterior distribution of parameters from accepted samples - std::vector< epiworld_double > m_accepted_stats; ///< Posterior distribution of statistics from accepted samples - std::vector< epiworld_double > m_accepted_kernel_scores; ///< Kernel scores for each accepted sample + std::vector< epiworld_double > m_all_accepted_params; ///< Posterior distribution of parameters from accepted samples + std::vector< epiworld_double > m_all_accepted_stats; ///< Posterior distribution of statistics from accepted samples + std::vector< epiworld_double > m_all_accepted_kernel_scores; ///< Kernel scores for each accepted sample // Functions LFMCMCSimFun m_simulation_fun; @@ -237,23 +239,25 @@ class LFMCMC { size_t get_n_params() const {return m_n_params;}; epiworld_double get_epsilon() const {return m_epsilon;}; - const std::vector< epiworld_double > & get_initial_params() {return m_initial_params;}; - const std::vector< epiworld_double > & get_current_params() {return m_current_params;}; - const std::vector< epiworld_double > & get_previous_params() {return m_previous_params;}; + const std::vector< epiworld_double > & get_initial_params() const {return m_initial_params;}; + const std::vector< epiworld_double > & get_current_proposed_params() const {return m_current_proposed_params;}; + const std::vector< epiworld_double > & get_current_accepted_params() const {return m_current_accepted_params;}; + const std::vector< epiworld_double > & get_current_proposed_stats() const {return m_current_proposed_stats;}; + const std::vector< epiworld_double > & get_current_accepted_stats() const {return m_current_accepted_stats;}; - const std::vector< epiworld_double > & get_observed_stats() {return m_observed_stats;}; + const std::vector< epiworld_double > & get_observed_stats() const {return m_observed_stats;}; - const std::vector< epiworld_double > & get_sample_params() {return m_sample_params;}; - const std::vector< epiworld_double > & get_sample_stats() {return m_sample_stats;}; - const std::vector< bool > & get_sample_acceptance() {return m_sample_acceptance;}; - const std::vector< epiworld_double > & get_sample_drawn_prob() {return m_sample_drawn_prob;}; - const std::vector< epiworld_double > & get_sample_kernel_scores() {return m_sample_kernel_scores;}; + const std::vector< epiworld_double > & get_all_sample_params() const {return m_all_sample_params;}; + const std::vector< epiworld_double > & get_all_sample_stats() const {return m_all_sample_stats;}; + const std::vector< bool > & get_all_sample_acceptance() const {return m_all_sample_acceptance;}; + const std::vector< epiworld_double > & get_all_sample_drawn_prob() const {return m_all_sample_drawn_prob;}; + const std::vector< epiworld_double > & get_all_sample_kernel_scores() const {return m_all_sample_kernel_scores;}; - const std::vector< epiworld_double > & get_accepted_params() {return m_accepted_params;}; - const std::vector< epiworld_double > & get_accepted_stats() {return m_accepted_stats;}; - const std::vector< epiworld_double > & get_accepted_kernel_scores() {return m_accepted_kernel_scores;}; + const std::vector< epiworld_double > & get_all_accepted_params() const {return m_all_accepted_params;}; + const std::vector< epiworld_double > & get_all_accepted_stats() const {return m_all_accepted_stats;}; + const std::vector< epiworld_double > & get_all_accepted_kernel_scores() const {return m_all_accepted_kernel_scores;}; - std::vector< TData > * get_simulated_data() {return m_simulated_data;}; + std::vector< TData > * get_simulated_data() const {return m_simulated_data;}; std::vector< epiworld_double > get_mean_params(); std::vector< epiworld_double > get_mean_stats(); diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp index 55efc4a..6a658ab 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp @@ -35,7 +35,7 @@ inline void LFMCMC::print(size_t burnin) const std::vector< epiworld_double > par_i(n_samples_print); for (size_t i = burnin; i < m_n_samples; ++i) { - par_i[i-burnin] = m_accepted_params[i * m_n_params + k]; + par_i[i-burnin] = m_all_accepted_params[i * m_n_params + k]; summ_params[k * 3] += par_i[i-burnin]/n_samples_dbl; } @@ -57,7 +57,7 @@ inline void LFMCMC::print(size_t burnin) const std::vector< epiworld_double > stat_k(n_samples_print); for (size_t i = burnin; i < m_n_samples; ++i) { - stat_k[i-burnin] = m_accepted_stats[i * m_n_stats + k]; + stat_k[i-burnin] = m_all_accepted_stats[i * m_n_stats + k]; summ_stats[k * 3] += stat_k[i-burnin]/n_samples_dbl; } diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp index c4f68f4..239f5fa 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp @@ -225,43 +225,50 @@ inline void LFMCMC::run( if (seed >= 0) this->seed(seed); - m_current_params.resize(m_n_params); - m_previous_params.resize(m_n_params); + m_current_proposed_params.resize(m_n_params); + m_current_accepted_params.resize(m_n_params); if (m_simulated_data != nullptr) m_simulated_data->resize(m_n_samples); - m_previous_params = m_initial_params; - m_current_params = m_initial_params; + m_current_accepted_params = m_initial_params; + m_current_proposed_params = m_initial_params; // Computing the baseline sufficient statistics m_summary_fun(m_observed_stats, m_observed_data, this); m_n_stats = m_observed_stats.size(); // Reserving size - m_sample_drawn_prob.resize(m_n_samples); - m_sample_acceptance.resize(m_n_samples, false); - m_sample_stats.resize(m_n_samples * m_n_stats); - m_sample_kernel_scores.resize(m_n_samples); - - m_accepted_params.resize(m_n_samples * m_n_params); - m_accepted_stats.resize(m_n_samples * m_n_stats); - m_accepted_kernel_scores.resize(m_n_samples); + m_current_proposed_stats.resize(m_n_stats); + m_current_accepted_stats.resize(m_n_stats); + m_all_sample_drawn_prob.resize(m_n_samples); + m_all_sample_acceptance.resize(m_n_samples, false); + m_all_sample_params.resize(m_n_samples * m_n_params); + m_all_sample_stats.resize(m_n_samples * m_n_stats); + m_all_sample_kernel_scores.resize(m_n_samples); + + m_all_accepted_params.resize(m_n_samples * m_n_params); + m_all_accepted_stats.resize(m_n_samples * m_n_stats); + m_all_accepted_kernel_scores.resize(m_n_samples); TData data_i = m_simulation_fun(m_initial_params, this); - std::vector< epiworld_double > proposed_stats_i; - m_summary_fun(proposed_stats_i, data_i, this); - m_accepted_kernel_scores[0u] = m_kernel_fun( - proposed_stats_i, m_observed_stats, m_epsilon, this + m_summary_fun(m_current_proposed_stats, data_i, this); + m_all_accepted_kernel_scores[0u] = m_kernel_fun( + m_current_proposed_stats, m_observed_stats, m_epsilon, this ); // Recording statistics for (size_t i = 0u; i < m_n_stats; ++i) - m_sample_stats[i] = proposed_stats_i[i]; + m_all_sample_stats[i] = m_current_proposed_stats[i]; + + m_current_accepted_stats = m_current_proposed_stats; for (size_t k = 0u; k < m_n_params; ++k) - m_accepted_params[k] = m_initial_params[k]; + m_all_accepted_params[k] = m_initial_params[k]; + + for (size_t k = 0u; k < m_n_params; ++k) + m_all_sample_params[k] = m_initial_params[k]; // Init progress bar progress_bar = Progress(m_n_samples, 80); @@ -272,59 +279,62 @@ inline void LFMCMC::run( // Run LFMCMC for (size_t i = 1u; i < m_n_samples; ++i) { - // Step 1: Generate a proposal and store it in m_current_params - m_proposal_fun(m_current_params, m_previous_params, this); + // Step 1: Generate a proposal and store it in m_current_proposed_params + m_proposal_fun(m_current_proposed_params, m_current_accepted_params, this); - // Step 2: Using m_current_params, simulate data - TData data_i = m_simulation_fun(m_current_params, this); + // Step 2: Using m_current_proposed_params, simulate data + TData data_i = m_simulation_fun(m_current_proposed_params, this); // Are we storing the data? if (m_simulated_data != nullptr) m_simulated_data->operator[](i) = data_i; // Step 3: Generate the summary statistics of the data - m_summary_fun(proposed_stats_i, data_i, this); + m_summary_fun(m_current_proposed_stats, data_i, this); // Step 4: Compute the hastings ratio using the kernel function epiworld_double hr = m_kernel_fun( - proposed_stats_i, m_observed_stats, m_epsilon, this + m_current_proposed_stats, m_observed_stats, m_epsilon, this ); - m_sample_kernel_scores[i] = hr; + m_all_sample_kernel_scores[i] = hr; // Storing data + for (size_t k = 0u; k < m_n_params; ++k) + m_all_sample_params[i * m_n_params + k] = m_current_proposed_params[k]; + for (size_t k = 0u; k < m_n_stats; ++k) - m_sample_stats[i * m_n_stats + k] = proposed_stats_i[k]; + m_all_sample_stats[i * m_n_stats + k] = m_current_proposed_stats[k]; // Running Hastings ratio epiworld_double r = runif(); - m_sample_drawn_prob[i] = r; + m_all_sample_drawn_prob[i] = r; // Step 5: Update if likely - if (r < std::min(static_cast(1.0), hr / m_accepted_kernel_scores[i - 1u])) + if (r < std::min(static_cast(1.0), hr / m_all_accepted_kernel_scores[i - 1u])) { - m_accepted_kernel_scores[i] = hr; - m_sample_acceptance[i] = true; + m_all_accepted_kernel_scores[i] = hr; + m_all_sample_acceptance[i] = true; for (size_t k = 0u; k < m_n_stats; ++k) - m_accepted_stats[i * m_n_stats + k] = - proposed_stats_i[k]; - - m_previous_params = m_current_params; + m_all_accepted_stats[i * m_n_stats + k] = + m_current_proposed_stats[k]; + m_current_accepted_params = m_current_proposed_params; + m_current_accepted_stats = m_current_proposed_stats; } else { for (size_t k = 0u; k < m_n_stats; ++k) - m_accepted_stats[i * m_n_stats + k] = - m_accepted_stats[(i - 1) * m_n_stats + k]; + m_all_accepted_stats[i * m_n_stats + k] = + m_all_accepted_stats[(i - 1) * m_n_stats + k]; - m_accepted_kernel_scores[i] = m_accepted_kernel_scores[i - 1u]; + m_all_accepted_kernel_scores[i] = m_all_accepted_kernel_scores[i - 1u]; } for (size_t k = 0u; k < m_n_params; ++k) - m_accepted_params[i * m_n_params + k] = m_previous_params[k]; + m_all_accepted_params[i * m_n_params + k] = m_current_accepted_params[k]; if (verbose) { progress_bar.next(); @@ -530,7 +540,7 @@ inline std::vector< epiworld_double > LFMCMC::get_mean_params() for (size_t k = 0u; k < m_n_params; ++k) { for (size_t i = 0u; i < m_n_samples; ++i) - res[k] += (this->m_accepted_params[k + m_n_params * i])/ + res[k] += (this->m_all_accepted_params[k + m_n_params * i])/ static_cast< epiworld_double >(m_n_samples); } @@ -546,7 +556,7 @@ inline std::vector< epiworld_double > LFMCMC::get_mean_stats() for (size_t k = 0u; k < m_n_stats; ++k) { for (size_t i = 0u; i < m_n_samples; ++i) - res[k] += (this->m_accepted_stats[k + m_n_stats * i])/ + res[k] += (this->m_all_accepted_stats[k + m_n_stats * i])/ static_cast< epiworld_double >(m_n_samples); } diff --git a/inst/tinytest/test-lfmcmc.R b/inst/tinytest/test-lfmcmc.R index 871e2a7..50e76e6 100644 --- a/inst/tinytest/test-lfmcmc.R +++ b/inst/tinytest/test-lfmcmc.R @@ -92,8 +92,11 @@ expect_stdout(run_lfmcmc( verbose_off(lfmcmc_model) # Check LFMCMC getters --------------------------------------------------------- +expect_equal(get_initial_params(lfmcmc_model), par0) expect_equal(get_n_samples(lfmcmc_model), n_samp) +expect_equal(get_observed_stats(lfmcmc_model), c(285, 0, 715)) + expected_stats_mean <- c(284.7140, 0.8485, 713.9375) expect_equal(get_mean_stats(lfmcmc_model), expected_stats_mean) expect_equal(get_n_stats(lfmcmc_model), length(expected_stats_mean)) @@ -102,8 +105,19 @@ expected_params_mean <- c(0.3133401, 0.2749686) expect_equal(get_mean_params(lfmcmc_model), expected_params_mean, tolerance = 0.0001) expect_equal(get_n_params(lfmcmc_model), length(expected_params_mean)) -expect_equal(dim(get_accepted_params(lfmcmc_model)), c(n_samp, length(expected_params_mean))) -expect_equal(dim(get_sample_stats(lfmcmc_model)), c(n_samp, length(expected_stats_mean))) +expect_equal(length(get_current_proposed_params(lfmcmc_model)), length(expected_params_mean)) +expect_equal(length(get_current_accepted_params(lfmcmc_model)), length(expected_params_mean)) +expect_equal(length(get_current_proposed_stats(lfmcmc_model)), length(expected_stats_mean)) +expect_equal(length(get_current_accepted_stats(lfmcmc_model)), length(expected_stats_mean)) + +expect_equal(dim(get_all_accepted_params(lfmcmc_model)), c(n_samp, length(expected_params_mean))) +expect_equal(dim(get_all_sample_params(lfmcmc_model)), c(n_samp, length(expected_params_mean))) +expect_equal(dim(get_all_sample_stats(lfmcmc_model)), c(n_samp, length(expected_stats_mean))) + +expect_equal(length(get_all_sample_acceptance(lfmcmc_model)), n_samp) +expect_equal(length(get_all_sample_drawn_prob(lfmcmc_model)), n_samp) +expect_equal(length(get_all_sample_kernel_scores(lfmcmc_model)), n_samp) +expect_equal(length(get_all_accepted_kernel_scores(lfmcmc_model)), n_samp) # Check LFMCMC using factory functions ----------------------------------------- expect_silent(use_proposal_norm_reflective(lfmcmc_model)) @@ -286,7 +300,6 @@ expect_equivalent( ) # Check functions fail when not passing an LFMCMC object ----------------------- -# Target is 56 tests expected_error_msg <- "must be an object of class epiworld_lfmcmc" not_lfmcmc <- c("NOT LFMCMC") @@ -311,9 +324,25 @@ expect_error(set_stats_names(not_lfmcmc, get_states(model_sir)), expected_error_ expect_error(get_mean_params(not_lfmcmc), expected_error_msg) expect_error(get_mean_stats(not_lfmcmc), expected_error_msg) -expect_error(get_accepted_params(not_lfmcmc), expected_error_msg) -expect_error(get_accepted_stats(not_lfmcmc), expected_error_msg) -expect_error(get_sample_stats(not_lfmcmc), expected_error_msg) -expect_error(get_n_params(not_lfmcmc), expected_error_msg) -expect_error(get_n_stats(not_lfmcmc), expected_error_msg) + +expect_error(get_initial_params(not_lfmcmc), expected_error_msg) +expect_error(get_current_proposed_params(not_lfmcmc), expected_error_msg) +expect_error(get_current_accepted_params(not_lfmcmc), expected_error_msg) +expect_error(get_current_proposed_stats(not_lfmcmc), expected_error_msg) +expect_error(get_current_accepted_stats(not_lfmcmc), expected_error_msg) + +expect_error(get_observed_stats(not_lfmcmc), expected_error_msg) + +expect_error(get_all_sample_params(not_lfmcmc), expected_error_msg) +expect_error(get_all_sample_stats(not_lfmcmc), expected_error_msg) +expect_error(get_all_sample_acceptance(not_lfmcmc), expected_error_msg) +expect_error(get_all_sample_drawn_prob(not_lfmcmc), expected_error_msg) +expect_error(get_all_sample_kernel_scores(not_lfmcmc), expected_error_msg) + +expect_error(get_all_accepted_params(not_lfmcmc), expected_error_msg) +expect_error(get_all_accepted_stats(not_lfmcmc), expected_error_msg) +expect_error(get_all_accepted_kernel_scores(not_lfmcmc), expected_error_msg) + expect_error(get_n_samples(not_lfmcmc), expected_error_msg) +expect_error(get_n_stats(not_lfmcmc), expected_error_msg) +expect_error(get_n_params(not_lfmcmc), expected_error_msg) \ No newline at end of file diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 06d062b..8b327c9 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -11,18 +11,29 @@ \alias{set_summary_fun} \alias{set_kernel_fun} \alias{use_kernel_fun_gaussian} -\alias{set_params_names} -\alias{set_stats_names} \alias{get_mean_params} \alias{get_mean_stats} -\alias{print.epiworld_lfmcmc} -\alias{get_accepted_params} -\alias{get_accepted_stats} -\alias{get_sample_stats} -\alias{get_n_params} -\alias{get_n_stats} +\alias{get_initial_params} +\alias{get_current_proposed_params} +\alias{get_current_accepted_params} +\alias{get_current_proposed_stats} +\alias{get_current_accepted_stats} +\alias{get_observed_stats} +\alias{get_all_sample_params} +\alias{get_all_sample_stats} +\alias{get_all_sample_acceptance} +\alias{get_all_sample_drawn_prob} +\alias{get_all_sample_kernel_scores} +\alias{get_all_accepted_params} +\alias{get_all_accepted_stats} +\alias{get_all_accepted_kernel_scores} \alias{get_n_samples} +\alias{get_n_stats} +\alias{get_n_params} \alias{verbose_off.epiworld_lfmcmc} +\alias{set_params_names} +\alias{set_stats_names} +\alias{print.epiworld_lfmcmc} \title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} \usage{ LFMCMC(model = NULL) @@ -43,29 +54,51 @@ set_kernel_fun(lfmcmc, fun) use_kernel_fun_gaussian(lfmcmc) -set_params_names(lfmcmc, names) - -set_stats_names(lfmcmc, names) - get_mean_params(lfmcmc) get_mean_stats(lfmcmc) -\method{print}{epiworld_lfmcmc}(x, burnin = 0, ...) +get_initial_params(lfmcmc) -get_accepted_params(lfmcmc) +get_current_proposed_params(lfmcmc) -get_accepted_stats(lfmcmc) +get_current_accepted_params(lfmcmc) -get_sample_stats(lfmcmc) +get_current_proposed_stats(lfmcmc) -get_n_params(lfmcmc) +get_current_accepted_stats(lfmcmc) -get_n_stats(lfmcmc) +get_observed_stats(lfmcmc) + +get_all_sample_params(lfmcmc) + +get_all_sample_stats(lfmcmc) + +get_all_sample_acceptance(lfmcmc) + +get_all_sample_drawn_prob(lfmcmc) + +get_all_sample_kernel_scores(lfmcmc) + +get_all_accepted_params(lfmcmc) + +get_all_accepted_stats(lfmcmc) + +get_all_accepted_kernel_scores(lfmcmc) get_n_samples(lfmcmc) +get_n_stats(lfmcmc) + +get_n_params(lfmcmc) + \method{verbose_off}{epiworld_lfmcmc}(x) + +set_params_names(lfmcmc, names) + +set_stats_names(lfmcmc, names) + +\method{print}{epiworld_lfmcmc}(x, burnin = 0, ...) } \arguments{ \item{model}{A model of class \link{epiworld_model} or \code{NULL} (see details).} @@ -84,10 +117,10 @@ get_n_samples(lfmcmc) \item{fun}{A function (see details).} -\item{names}{Character vector of names.} - \item{x}{LFMCMC model to print} +\item{names}{Character vector of names.} + \item{burnin}{Integer. Number of samples to discard as burnin before computing the summary.} @@ -104,43 +137,92 @@ gaussian. } \itemize{ -\item \code{set_params_names}: The lfmcmc model with the parameter names added. +\item \code{get_mean_params}: The param means for the given lfmcmc model. } \itemize{ -\item \code{set_stats_names}: The lfmcmc model with the stats names added. +\item \code{get_mean_stats}: The stats means for the given lfmcmc model. } \itemize{ -\item \code{get_mean_params}: The param means for the given lfmcmc model. +\item The function \code{get_initial_params} returns the initial parameters +for the given LFMCMC model. } \itemize{ -\item \code{get_mean_stats}: The stats means for the given lfmcmc model. +\item The function \code{get_current_proposed_params} returns the proposed parameters +for the next LFMCMC sample. +} + +\itemize{ +\item The function \code{get_current_accepted_params} returns the most recently accepted +parameters (the current state of the LFMCMC) } \itemize{ -\item The function \code{get_accepted_params} returns a matrix of accepted +\item The function \code{get_current_proposed_stats} returns the statistics +from the simulation run with the proposed parameters +} + +\itemize{ +\item The function \code{get_current_accepted_stats} returns the statistics +from the most recently accepted parameters +} + +\itemize{ +\item The function \code{get_observed_stats} returns the statistics +for the observed data +} + +\itemize{ +\item The function \code{get_all_sample_params} returns a matrix of sample parameters for the given LFMCMC model. with the number of rows equal to the number of samples and the number of columns equal to the number of parameters. } \itemize{ -\item The function \code{get_accepted_stats} returns a matrix of accepted statistics +\item The function \code{get_all_sample_stats} returns a matrix of statistics for the given LFMCMC model. with the number of rows equal to the number of samples and the number of columns equal to the number of statistics. } \itemize{ -\item The function \code{get_sample_stats} returns a matrix of statistics +\item The function \code{get_all_sample_acceptance} returns a vector of boolean flags +which indicate whether a given sample was accepted +} + +\itemize{ +\item The function \code{get_all_sample_drawn_prob} returns a vector of drawn probabilities +for each sample +} + +\itemize{ +\item The function \code{get_all_sample_kernel_scores} returns a vector of kernel scores for +each sample +} + +\itemize{ +\item The function \code{get_all_accepted_params} returns a matrix of accepted +parameters for the given LFMCMC model. with the number of rows equal to the +number of samples and the number of columns equal to the number of +parameters. +} + +\itemize{ +\item The function \code{get_all_accepted_stats} returns a matrix of accepted statistics for the given LFMCMC model. with the number of rows equal to the number of samples and the number of columns equal to the number of statistics. } \itemize{ -\item The functions \code{get_n_params}, \code{get_n_stats}, and \code{get_n_samples} -return the number of parameters, statistics, and samples for the given +\item The function \code{get_all_accepted_kernel_scores} returns a vector of kernel scores for +each accepted sample +} + +\itemize{ +\item The functions \code{get_n_samples}, \code{get_n_stats}, and \code{get_n_params} +return the number of samples, statistics, and parameters for the given LFMCMC model, respectively. } @@ -148,6 +230,14 @@ LFMCMC model, respectively. \item The \code{verbose_on} and \code{verbose_off} functions return the same model, however \code{verbose_off} returns the model with no progress bar. } + +\itemize{ +\item \code{set_params_names}: The lfmcmc model with the parameter names added. +} + +\itemize{ +\item \code{set_stats_names}: The lfmcmc model with the stats names added. +} } \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 71aa01b..97e0863 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -454,59 +454,115 @@ extern "C" SEXP _epiworldR_use_kernel_fun_gaussian_cpp(SEXP lfmcmc) { END_CPP11 } // lfmcmc.cpp -SEXP set_params_names_cpp(SEXP lfmcmc, std::vector< std::string > names); -extern "C" SEXP _epiworldR_set_params_names_cpp(SEXP lfmcmc, SEXP names) { +cpp11::writable::doubles get_mean_params_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_mean_params_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(set_params_names_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(names))); + return cpp11::as_sexp(get_mean_params_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp -SEXP set_stats_names_cpp(SEXP lfmcmc, std::vector< std::string > names); -extern "C" SEXP _epiworldR_set_stats_names_cpp(SEXP lfmcmc, SEXP names) { +cpp11::writable::doubles get_mean_stats_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_mean_stats_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(set_stats_names_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(names))); + return cpp11::as_sexp(get_mean_stats_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp -cpp11::writable::doubles get_mean_params_cpp(SEXP lfmcmc); -extern "C" SEXP _epiworldR_get_mean_params_cpp(SEXP lfmcmc) { +cpp11::writable::doubles get_initial_params_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_initial_params_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(get_mean_params_cpp(cpp11::as_cpp>(lfmcmc))); + return cpp11::as_sexp(get_initial_params_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp -cpp11::writable::doubles get_mean_stats_cpp(SEXP lfmcmc); -extern "C" SEXP _epiworldR_get_mean_stats_cpp(SEXP lfmcmc) { +cpp11::writable::doubles get_current_proposed_params_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_current_proposed_params_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(get_mean_stats_cpp(cpp11::as_cpp>(lfmcmc))); + return cpp11::as_sexp(get_current_proposed_params_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp -SEXP print_lfmcmc_cpp(SEXP lfmcmc, int burnin); -extern "C" SEXP _epiworldR_print_lfmcmc_cpp(SEXP lfmcmc, SEXP burnin) { +cpp11::writable::doubles get_current_accepted_params_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_current_accepted_params_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(print_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(burnin))); + return cpp11::as_sexp(get_current_accepted_params_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +cpp11::writable::doubles get_current_proposed_stats_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_current_proposed_stats_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_current_proposed_stats_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +cpp11::writable::doubles get_current_accepted_stats_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_current_accepted_stats_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_current_accepted_stats_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +cpp11::writable::doubles get_observed_stats_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_observed_stats_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_observed_stats_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +SEXP get_all_sample_params_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_sample_params_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_all_sample_params_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp -SEXP get_sample_stats_cpp(SEXP lfmcmc); -extern "C" SEXP _epiworldR_get_sample_stats_cpp(SEXP lfmcmc) { +SEXP get_all_sample_stats_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_sample_stats_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(get_sample_stats_cpp(cpp11::as_cpp>(lfmcmc))); + return cpp11::as_sexp(get_all_sample_stats_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp -SEXP get_accepted_params_cpp(SEXP lfmcmc); -extern "C" SEXP _epiworldR_get_accepted_params_cpp(SEXP lfmcmc) { +cpp11::writable::doubles get_all_sample_acceptance_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_sample_acceptance_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(get_accepted_params_cpp(cpp11::as_cpp>(lfmcmc))); + return cpp11::as_sexp(get_all_sample_acceptance_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp -SEXP get_accepted_stats_cpp(SEXP lfmcmc); -extern "C" SEXP _epiworldR_get_accepted_stats_cpp(SEXP lfmcmc) { +cpp11::writable::doubles get_all_sample_drawn_prob_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_sample_drawn_prob_cpp(SEXP lfmcmc) { BEGIN_CPP11 - return cpp11::as_sexp(get_accepted_stats_cpp(cpp11::as_cpp>(lfmcmc))); + return cpp11::as_sexp(get_all_sample_drawn_prob_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +cpp11::writable::doubles get_all_sample_kernel_scores_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_sample_kernel_scores_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_all_sample_kernel_scores_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +SEXP get_all_accepted_params_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_accepted_params_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_all_accepted_params_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +SEXP get_all_accepted_stats_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_accepted_stats_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_all_accepted_stats_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +SEXP get_all_accepted_kernel_scores_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_get_all_accepted_kernel_scores_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(get_all_accepted_kernel_scores_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } // lfmcmc.cpp @@ -544,6 +600,27 @@ extern "C" SEXP _epiworldR_verbose_on_lfmcmc_cpp(SEXP lfmcmc) { return cpp11::as_sexp(verbose_on_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } +// lfmcmc.cpp +SEXP set_params_names_cpp(SEXP lfmcmc, std::vector< std::string > names); +extern "C" SEXP _epiworldR_set_params_names_cpp(SEXP lfmcmc, SEXP names) { + BEGIN_CPP11 + return cpp11::as_sexp(set_params_names_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(names))); + END_CPP11 +} +// lfmcmc.cpp +SEXP set_stats_names_cpp(SEXP lfmcmc, std::vector< std::string > names); +extern "C" SEXP _epiworldR_set_stats_names_cpp(SEXP lfmcmc, SEXP names) { + BEGIN_CPP11 + return cpp11::as_sexp(set_stats_names_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(names))); + END_CPP11 +} +// lfmcmc.cpp +SEXP print_lfmcmc_cpp(SEXP lfmcmc, int burnin); +extern "C" SEXP _epiworldR_print_lfmcmc_cpp(SEXP lfmcmc, SEXP burnin) { + BEGIN_CPP11 + return cpp11::as_sexp(print_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(burnin))); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1115,13 +1192,23 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_entity_add_agent_cpp", (DL_FUNC) &_epiworldR_entity_add_agent_cpp, 3}, {"_epiworldR_entity_cpp", (DL_FUNC) &_epiworldR_entity_cpp, 4}, {"_epiworldR_entity_get_agents_cpp", (DL_FUNC) &_epiworldR_entity_get_agents_cpp, 1}, - {"_epiworldR_get_accepted_params_cpp", (DL_FUNC) &_epiworldR_get_accepted_params_cpp, 1}, - {"_epiworldR_get_accepted_stats_cpp", (DL_FUNC) &_epiworldR_get_accepted_stats_cpp, 1}, {"_epiworldR_get_agent_cpp", (DL_FUNC) &_epiworldR_get_agent_cpp, 2}, {"_epiworldR_get_agents_cpp", (DL_FUNC) &_epiworldR_get_agents_cpp, 1}, {"_epiworldR_get_agents_data_ncols_cpp", (DL_FUNC) &_epiworldR_get_agents_data_ncols_cpp, 1}, {"_epiworldR_get_agents_states_cpp", (DL_FUNC) &_epiworldR_get_agents_states_cpp, 1}, {"_epiworldR_get_agents_tools_cpp", (DL_FUNC) &_epiworldR_get_agents_tools_cpp, 1}, + {"_epiworldR_get_all_accepted_kernel_scores_cpp", (DL_FUNC) &_epiworldR_get_all_accepted_kernel_scores_cpp, 1}, + {"_epiworldR_get_all_accepted_params_cpp", (DL_FUNC) &_epiworldR_get_all_accepted_params_cpp, 1}, + {"_epiworldR_get_all_accepted_stats_cpp", (DL_FUNC) &_epiworldR_get_all_accepted_stats_cpp, 1}, + {"_epiworldR_get_all_sample_acceptance_cpp", (DL_FUNC) &_epiworldR_get_all_sample_acceptance_cpp, 1}, + {"_epiworldR_get_all_sample_drawn_prob_cpp", (DL_FUNC) &_epiworldR_get_all_sample_drawn_prob_cpp, 1}, + {"_epiworldR_get_all_sample_kernel_scores_cpp", (DL_FUNC) &_epiworldR_get_all_sample_kernel_scores_cpp, 1}, + {"_epiworldR_get_all_sample_params_cpp", (DL_FUNC) &_epiworldR_get_all_sample_params_cpp, 1}, + {"_epiworldR_get_all_sample_stats_cpp", (DL_FUNC) &_epiworldR_get_all_sample_stats_cpp, 1}, + {"_epiworldR_get_current_accepted_params_cpp", (DL_FUNC) &_epiworldR_get_current_accepted_params_cpp, 1}, + {"_epiworldR_get_current_accepted_stats_cpp", (DL_FUNC) &_epiworldR_get_current_accepted_stats_cpp, 1}, + {"_epiworldR_get_current_proposed_params_cpp", (DL_FUNC) &_epiworldR_get_current_proposed_params_cpp, 1}, + {"_epiworldR_get_current_proposed_stats_cpp", (DL_FUNC) &_epiworldR_get_current_proposed_stats_cpp, 1}, {"_epiworldR_get_entities_cpp", (DL_FUNC) &_epiworldR_get_entities_cpp, 1}, {"_epiworldR_get_entity_cpp", (DL_FUNC) &_epiworldR_get_entity_cpp, 2}, {"_epiworldR_get_entity_name_cpp", (DL_FUNC) &_epiworldR_get_entity_name_cpp, 1}, @@ -1131,6 +1218,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_get_hist_total_cpp", (DL_FUNC) &_epiworldR_get_hist_total_cpp, 1}, {"_epiworldR_get_hist_transition_matrix_cpp", (DL_FUNC) &_epiworldR_get_hist_transition_matrix_cpp, 2}, {"_epiworldR_get_hist_virus_cpp", (DL_FUNC) &_epiworldR_get_hist_virus_cpp, 1}, + {"_epiworldR_get_initial_params_cpp", (DL_FUNC) &_epiworldR_get_initial_params_cpp, 1}, {"_epiworldR_get_mean_params_cpp", (DL_FUNC) &_epiworldR_get_mean_params_cpp, 1}, {"_epiworldR_get_mean_stats_cpp", (DL_FUNC) &_epiworldR_get_mean_stats_cpp, 1}, {"_epiworldR_get_n_params_cpp", (DL_FUNC) &_epiworldR_get_n_params_cpp, 1}, @@ -1144,9 +1232,9 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_get_name_virus_cpp", (DL_FUNC) &_epiworldR_get_name_virus_cpp, 1}, {"_epiworldR_get_ndays_cpp", (DL_FUNC) &_epiworldR_get_ndays_cpp, 1}, {"_epiworldR_get_network_cpp", (DL_FUNC) &_epiworldR_get_network_cpp, 1}, + {"_epiworldR_get_observed_stats_cpp", (DL_FUNC) &_epiworldR_get_observed_stats_cpp, 1}, {"_epiworldR_get_param_cpp", (DL_FUNC) &_epiworldR_get_param_cpp, 2}, {"_epiworldR_get_reproductive_number_cpp", (DL_FUNC) &_epiworldR_get_reproductive_number_cpp, 1}, - {"_epiworldR_get_sample_stats_cpp", (DL_FUNC) &_epiworldR_get_sample_stats_cpp, 1}, {"_epiworldR_get_state_agent_cpp", (DL_FUNC) &_epiworldR_get_state_agent_cpp, 1}, {"_epiworldR_get_states_cpp", (DL_FUNC) &_epiworldR_get_states_cpp, 1}, {"_epiworldR_get_today_total_cpp", (DL_FUNC) &_epiworldR_get_today_total_cpp, 1}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index a7cf550..16bcabc 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -219,79 +219,141 @@ SEXP use_kernel_fun_gaussian_cpp( } // ************************************* -// LFMCMC Printing Functions +// LFMCMC Getters - Params and Stats // ************************************* [[cpp11::register]] -SEXP set_params_names_cpp( - SEXP lfmcmc, - std::vector< std::string > names +cpp11::writable::doubles get_mean_params_cpp( + SEXP lfmcmc ) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_params_names(names); - return lfmcmc; + return cpp11::doubles(lfmcmc_ptr->get_mean_params()); } [[cpp11::register]] -SEXP set_stats_names_cpp( - SEXP lfmcmc, - std::vector< std::string > names +cpp11::writable::doubles get_mean_stats_cpp( + SEXP lfmcmc ) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_stats_names(names); - return lfmcmc; + return cpp11::doubles(lfmcmc_ptr->get_mean_stats()); } [[cpp11::register]] -cpp11::writable::doubles get_mean_params_cpp( - SEXP lfmcmc -) { +cpp11::writable::doubles get_initial_params_cpp(SEXP lfmcmc) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - return cpp11::doubles(lfmcmc_ptr->get_mean_params()); + return cpp11::doubles(lfmcmc_ptr->get_initial_params()); + } [[cpp11::register]] -cpp11::writable::doubles get_mean_stats_cpp( - SEXP lfmcmc -) { +cpp11::writable::doubles get_current_proposed_params_cpp(SEXP lfmcmc) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - return cpp11::doubles(lfmcmc_ptr->get_mean_stats()); + return cpp11::doubles(lfmcmc_ptr->get_current_proposed_params()); + } [[cpp11::register]] -SEXP print_lfmcmc_cpp( - SEXP lfmcmc, - int burnin -) { +cpp11::writable::doubles get_current_accepted_params_cpp(SEXP lfmcmc) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->print(static_cast(burnin)); - return lfmcmc; + return cpp11::doubles(lfmcmc_ptr->get_current_accepted_params()); + +} + +[[cpp11::register]] +cpp11::writable::doubles get_current_proposed_stats_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_current_proposed_stats()); + +} + +[[cpp11::register]] +cpp11::writable::doubles get_current_accepted_stats_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_current_accepted_stats()); + +} + +[[cpp11::register]] +cpp11::writable::doubles get_observed_stats_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_observed_stats()); + +} + +[[cpp11::register]] +SEXP get_all_sample_params_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_all_sample_params()); + } [[cpp11::register]] -SEXP get_sample_stats_cpp(SEXP lfmcmc) { +SEXP get_all_sample_stats_cpp(SEXP lfmcmc) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - return cpp11::doubles(lfmcmc_ptr->get_sample_stats()); + return cpp11::doubles(lfmcmc_ptr->get_all_sample_stats()); } [[cpp11::register]] -SEXP get_accepted_params_cpp(SEXP lfmcmc) { +cpp11::writable::doubles get_all_sample_acceptance_cpp(SEXP lfmcmc) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - return cpp11::doubles(lfmcmc_ptr->get_accepted_params()); + return cpp11::doubles(lfmcmc_ptr->get_all_sample_acceptance()); } [[cpp11::register]] -SEXP get_accepted_stats_cpp(SEXP lfmcmc) { +cpp11::writable::doubles get_all_sample_drawn_prob_cpp(SEXP lfmcmc) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - return cpp11::doubles(lfmcmc_ptr->get_accepted_stats()); + return cpp11::doubles(lfmcmc_ptr->get_all_sample_drawn_prob()); } +[[cpp11::register]] +cpp11::writable::doubles get_all_sample_kernel_scores_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_all_sample_kernel_scores()); + +} + +[[cpp11::register]] +SEXP get_all_accepted_params_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_all_accepted_params()); + +} + +[[cpp11::register]] +SEXP get_all_accepted_stats_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_all_accepted_stats()); + +} + +[[cpp11::register]] +SEXP get_all_accepted_kernel_scores_cpp(SEXP lfmcmc) { + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + return cpp11::doubles(lfmcmc_ptr->get_all_accepted_kernel_scores()); + +} + +// ************************************* +// LFMCMC Getters - N values +// ************************************* + [[cpp11::register]] int get_n_samples_cpp(SEXP lfmcmc) { @@ -316,6 +378,10 @@ int get_n_params_cpp(SEXP lfmcmc) { } +// ************************************* +// LFMCMC Printing functions +// ************************************* + [[cpp11::register]] SEXP verbose_off_lfmcmc_cpp(SEXP lfmcmc) { @@ -334,4 +400,34 @@ SEXP verbose_on_lfmcmc_cpp(SEXP lfmcmc) { } +[[cpp11::register]] +SEXP set_params_names_cpp( + SEXP lfmcmc, + std::vector< std::string > names +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_params_names(names); + return lfmcmc; +} + +[[cpp11::register]] +SEXP set_stats_names_cpp( + SEXP lfmcmc, + std::vector< std::string > names +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_stats_names(names); + return lfmcmc; +} + +[[cpp11::register]] +SEXP print_lfmcmc_cpp( + SEXP lfmcmc, + int burnin +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->print(static_cast(burnin)); + return lfmcmc; +} + #undef WrapLFMCMC