diff --git a/NAMESPACE b/NAMESPACE index 1a5b79cd..38fb75ea 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -83,6 +83,7 @@ S3method(set_observed_data,epiworld_lfmcmc) S3method(set_par_names,epiworld_lfmcmc) S3method(set_param,epiworld_model) S3method(set_proposal_fun,epiworld_lfmcmc) +S3method(set_rand_engine_lfmcmc,epiworld_lfmcmc) S3method(set_simulation_fun,epiworld_lfmcmc) S3method(set_stats_names,epiworld_lfmcmc) S3method(set_summary_fun,epiworld_lfmcmc) @@ -209,6 +210,7 @@ export(set_prob_recovery) export(set_prob_recovery_fun) export(set_prob_recovery_ptr) export(set_proposal_fun) +export(set_rand_engine_lfmcmc) export(set_recovery_enhancer) export(set_recovery_enhancer_fun) export(set_recovery_enhancer_ptr) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 4b31de96..bba116f1 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -4,14 +4,18 @@ #' @aliases epiworld_lfmcmc #' @details #' TODO: Detail LFMCMC +#' TODO: Add params #' @returns #' - The `LFMCMC`function returns a model of class [epiworld_lfmcmc]. #' @examples #' model_lfmcmc <- LFMCMC() #' @export -LFMCMC <- function() { +LFMCMC <- function(model) { + if (!inherits(model, "epiworld_model")) + stop("model should be of class 'epiworld_model'. It is of class ", class(model)) + structure( - LFMCMC_cpp(), + LFMCMC_cpp(model), class = c("epiworld_lfmcmc") ) } @@ -96,6 +100,19 @@ set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { invisible(lfmcmc) } +#' @rdname LFMCMC +#' @param lfmcmc LFMCMC model +#' @param eng The rand engine +#' @returns The lfmcmc model with the engine set +#' @export +set_rand_engine_lfmcmc <- function(lfmcmc, eng) UseMethod("set_rand_engine_lfmcmc") + +#' @export +set_rand_engine_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, eng) { + set_rand_engine_lfmcmc_cpp(lfmcmc, eng) + invisible(lfmcmc) +} + #' @rdname LFMCMC #' @param lfmcmc LFMCMC model #' @param s The rand engine seed diff --git a/R/cpp11.R b/R/cpp11.R index 1106bbfd..110cb1cd 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -220,8 +220,8 @@ ModelSEIRMixing_cpp <- function(name, n, prevalence, contact_rate, transmission_ .Call(`_epiworldR_ModelSEIRMixing_cpp`, name, n, prevalence, contact_rate, transmission_rate, incubation_days, recovery_rate, contact_matrix) } -LFMCMC_cpp <- function() { - .Call(`_epiworldR_LFMCMC_cpp`) +LFMCMC_cpp <- function(m) { + .Call(`_epiworldR_LFMCMC_cpp`, m) } run_lfmcmc_cpp <- function(lfmcmc, params_init_, n_samples_, epsilon_) { @@ -264,6 +264,10 @@ set_kernel_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_kernel_fun_cpp`, lfmcmc, fun) } +set_rand_engine_lfmcmc_cpp <- function(lfmcmc, eng) { + .Call(`_epiworldR_set_rand_engine_lfmcmc_cpp`, lfmcmc, eng) +} + seed_lfmcmc_cpp <- function(lfmcmc, s) { .Call(`_epiworldR_seed_lfmcmc_cpp`, lfmcmc, s) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 32f63a34..f15c0f50 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -9,13 +9,14 @@ \alias{set_simulation_fun} \alias{set_summary_fun} \alias{set_kernel_fun} +\alias{set_rand_engine_lfmcmc} \alias{seed_lfmcmc} \alias{set_par_names} \alias{set_stats_names} \alias{print.epiworld_lfmcmc} \title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} \usage{ -LFMCMC() +LFMCMC(model) run_lfmcmc(lfmcmc, params_init_, n_samples_, epsilon_) @@ -29,6 +30,8 @@ set_summary_fun(lfmcmc, fun) set_kernel_fun(lfmcmc, fun) +set_rand_engine_lfmcmc(lfmcmc, eng) + seed_lfmcmc(lfmcmc, s) set_par_names(lfmcmc, names) @@ -50,6 +53,8 @@ set_stats_names(lfmcmc, names) \item{fun}{The LFMCMC kernel function} +\item{eng}{The rand engine} + \item{s}{The rand engine seed} \item{names}{The model stats names} @@ -75,6 +80,8 @@ The lfmcmc model with the summary function added The lfmcmc model with the kernel function added +The lfmcmc model with the engine set + The lfmcmc model with the seed set The lfmcmc model with the parameter names added @@ -88,6 +95,7 @@ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) } \details{ TODO: Detail LFMCMC +TODO: Add params } \examples{ model_lfmcmc <- LFMCMC() diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 39237a59..f4dd141f 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -391,10 +391,10 @@ extern "C" SEXP _epiworldR_ModelSEIRMixing_cpp(SEXP name, SEXP n, SEXP prevalenc END_CPP11 } // lfmcmc.cpp -SEXP LFMCMC_cpp(); -extern "C" SEXP _epiworldR_LFMCMC_cpp() { +SEXP LFMCMC_cpp(SEXP m); +extern "C" SEXP _epiworldR_LFMCMC_cpp(SEXP m) { BEGIN_CPP11 - return cpp11::as_sexp(LFMCMC_cpp()); + return cpp11::as_sexp(LFMCMC_cpp(cpp11::as_cpp>(m))); END_CPP11 } // lfmcmc.cpp @@ -468,6 +468,13 @@ extern "C" SEXP _epiworldR_set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun) { END_CPP11 } // lfmcmc.cpp +SEXP set_rand_engine_lfmcmc_cpp(SEXP lfmcmc, SEXP eng); +extern "C" SEXP _epiworldR_set_rand_engine_lfmcmc_cpp(SEXP lfmcmc, SEXP eng) { + BEGIN_CPP11 + return cpp11::as_sexp(set_rand_engine_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(eng))); + END_CPP11 +} +// lfmcmc.cpp SEXP seed_lfmcmc_cpp(SEXP lfmcmc, unsigned long long int s); extern "C" SEXP _epiworldR_seed_lfmcmc_cpp(SEXP lfmcmc, SEXP s) { BEGIN_CPP11 @@ -1016,7 +1023,7 @@ extern "C" SEXP _epiworldR_distribute_virus_to_set_cpp(SEXP agents_ids) { extern "C" { static const R_CallMethodDef CallEntries[] = { - {"_epiworldR_LFMCMC_cpp", (DL_FUNC) &_epiworldR_LFMCMC_cpp, 0}, + {"_epiworldR_LFMCMC_cpp", (DL_FUNC) &_epiworldR_LFMCMC_cpp, 1}, {"_epiworldR_ModelDiffNet_cpp", (DL_FUNC) &_epiworldR_ModelDiffNet_cpp, 8}, {"_epiworldR_ModelSEIRCONN_cpp", (DL_FUNC) &_epiworldR_ModelSEIRCONN_cpp, 7}, {"_epiworldR_ModelSEIRDCONN_cpp", (DL_FUNC) &_epiworldR_ModelSEIRDCONN_cpp, 8}, @@ -1140,6 +1147,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_set_prob_recovery_fun_cpp", (DL_FUNC) &_epiworldR_set_prob_recovery_fun_cpp, 3}, {"_epiworldR_set_prob_recovery_ptr_cpp", (DL_FUNC) &_epiworldR_set_prob_recovery_ptr_cpp, 3}, {"_epiworldR_set_proposal_fun_cpp", (DL_FUNC) &_epiworldR_set_proposal_fun_cpp, 2}, + {"_epiworldR_set_rand_engine_lfmcmc_cpp", (DL_FUNC) &_epiworldR_set_rand_engine_lfmcmc_cpp, 2}, {"_epiworldR_set_recovery_enhancer_cpp", (DL_FUNC) &_epiworldR_set_recovery_enhancer_cpp, 2}, {"_epiworldR_set_recovery_enhancer_fun_cpp", (DL_FUNC) &_epiworldR_set_recovery_enhancer_fun_cpp, 3}, {"_epiworldR_set_recovery_enhancer_ptr_cpp", (DL_FUNC) &_epiworldR_set_recovery_enhancer_ptr_cpp, 3}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 8866ccc4..44c466bd 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -15,11 +15,15 @@ using namespace epiworld; // https://github.com/UofUEpiBio/epiworld/tree/master/include/epiworld/math/lfmcmc [[cpp11::register]] -SEXP LFMCMC_cpp() { +SEXP LFMCMC_cpp( + SEXP m +) { WrapLFMCMC(lfmcmc_ptr)( new LFMCMC() ); + lfmcmc_ptr->set_rand_engine(cpp11::external_pointer>(m)->get_rand_endgine()); + return lfmcmc_ptr; } @@ -131,7 +135,6 @@ SEXP set_summary_fun_cpp( } // LFMCMC Kernel Function -// TODO: clean up these really long lines [[cpp11::register]] SEXP create_LFMCMCKernelFun_cpp( cpp11::function fun @@ -159,6 +162,18 @@ SEXP set_kernel_fun_cpp( return lfmcmc; } +// Rand Engine +[[cpp11::register]] +SEXP set_rand_engine_lfmcmc_cpp( + SEXP lfmcmc, + SEXP eng +) { + cpp11::external_pointer eng_ptr(eng); + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_rand_engine(*eng_ptr); + return lfmcmc; +} + // s should be of type epiworld_fast_uint [[cpp11::register]] SEXP seed_lfmcmc_cpp( diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 9acba8bc..d90f1bb5 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -56,7 +56,7 @@ print(model_sir) ## Extract Observed data ```{r extract-obs-data} -obs_data <- get_today_total(model_sir) +obs_data <- as.integer(get_today_total(model_sir)) ``` ## Setup LFMCMC @@ -100,18 +100,17 @@ par0 <- c(.5, .5) ## Run LFMCMC ```{r lfmcmc-run} # TODO: make these work -lfmcmc_model <- LFMCMC() |> +lfmcmc_model <- LFMCMC(model_sir) |> set_simulation_fun(simfun) |> set_summary_fun(sumfun) |> set_proposal_fun(propfun) |> - set_kernel_fun(kernfun) -# set_observed_data(obs_dat) |> -# run_lfmcmc(par0, 2000, 1) + set_kernel_fun(kernfun) |> + set_observed_data(obs_data) +# run_lfmcmc(par0, 2000, 1) # lfmcmc_model -# lfmcmc_model <- seed(lfmcmc_model, model_seed) |> -# set_par_names(c("Immune recovery", "Infectiousness")) |> +# lfmcmc_model <- set_par_names(c("Immune recovery", "Infectiousness")) |> # set_stats_names(get_states(model_sir)) |> # print() ```