Export LFMCMC

.devcontainer/Dockerfile

@@ -10,4 +10,6 @@
 
 RUN install2.r languageserver
 
+RUN apt-get update && apt-get install --no-install-recommends -y valgrind gdb
+
 CMD ["bash"]

.gitignore

@@ -20,3 +20,6 @@ src/Makevars
 images
 inst/doc
 docs
+
+config.log
+config.status

.vscode/settings.json

@@ -54,7 +54,8 @@
         "stdexcept": "cpp",
         "streambuf": "cpp",
         "typeinfo": "cpp",
-        "thread": "cpp"
+        "thread": "cpp",
+        "cinttypes": "cpp"
     },
     "editor.indentSize": "tabSize",
     "[r]": {

Makefile

@@ -46,9 +46,14 @@ clean:
 	sed -i -E 's/^library\(epiworldRdev\)/library(epiworldR)/g' README.*
 
 docs:
-	Rscript --vanilla -e 'roxygen2::roxigenize()'
-
-.PHONY: build update check clean docs docker-debug
+	Rscript --vanilla -e 'roxygen2::roxygenize()'
 
 checkv: build
 	R CMD check --as-cran --use-valgrind epiworldR*.tar.gz
+
+# Builds and installs without vignettes
+dev: clean
+	R CMD build --no-build-vignettes .
+	R CMD INSTALL epiworldR_$(VERSION).tar.gz
+
+.PHONY: build update check clean docs docker-debug dev

NAMESPACE

@@ -62,6 +62,7 @@ S3method(print,epiworld_agents_tools)
 S3method(print,epiworld_entities)
 S3method(print,epiworld_entity)
 S3method(print,epiworld_globalevent)
+S3method(print,epiworld_lfmcmc)
 S3method(print,epiworld_model)
 S3method(print,epiworld_saver)
 S3method(print,epiworld_tool)
@@ -73,13 +74,22 @@ S3method(queuing_on,epiworld_model)
 S3method(queuing_on,epiworld_seirconn)
 S3method(queuing_on,epiworld_sirconn)
 S3method(run,epiworld_model)
+S3method(run_lfmcmc,epiworld_lfmcmc)
 S3method(run_multiple,epiworld_model)
+S3method(set_kernel_fun,epiworld_lfmcmc)
 S3method(set_name,epiworld_model)
+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_simulation_fun,epiworld_lfmcmc)
+S3method(set_stats_names,epiworld_lfmcmc)
+S3method(set_summary_fun,epiworld_lfmcmc)
 S3method(size,epiworld_model)
 S3method(summary,epiworld_model)
 S3method(verbose_off,epiworld_model)
 S3method(verbose_on,epiworld_model)
+export(LFMCMC)
 export(ModelDiffNet)
 export(ModelSEIR)
 export(ModelSEIRCONN)
@@ -167,6 +177,7 @@ export(rm_entity)
 export(rm_tool)
 export(rm_virus)
 export(run)
+export(run_lfmcmc)
 export(run_multiple)
 export(run_multiple_get_results)
 export(set_agents_data)
@@ -179,9 +190,12 @@ export(set_distribution_virus)
 export(set_incubation)
 export(set_incubation_fun)
 export(set_incubation_ptr)
+export(set_kernel_fun)
 export(set_name)
 export(set_name_tool)
 export(set_name_virus)
+export(set_observed_data)
+export(set_par_names)
 export(set_param)
 export(set_prob_death)
 export(set_prob_death_fun)
@@ -192,9 +206,13 @@ export(set_prob_infecting_ptr)
 export(set_prob_recovery)
 export(set_prob_recovery_fun)
 export(set_prob_recovery_ptr)
+export(set_proposal_fun)
 export(set_recovery_enhancer)
 export(set_recovery_enhancer_fun)
 export(set_recovery_enhancer_ptr)
+export(set_simulation_fun)
+export(set_stats_names)
+export(set_summary_fun)
 export(set_susceptibility_reduction)
 export(set_susceptibility_reduction_fun)
 export(set_susceptibility_reduction_ptr)
@@ -204,6 +222,8 @@ export(set_transmission_reduction_ptr)
 export(size)
 export(tool)
 export(tool_fun_logit)
+export(use_kernel_fun_gaussian)
+export(use_proposal_norm_reflective)
 export(verbose_off)
 export(verbose_on)
 export(virus)

R/LFMCMC.R

@@ -0,0 +1,216 @@
+#' Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)
+#'
+#'
+#' @aliases epiworld_lfmcmc
+#' @details
+#' Performs a Likelihood-Free Markhov Chain Monte Carlo simulation
+#' @param model A model of class [epiworld_model]
+#' @returns
+#' The `LFMCMC` function returns a model of class [epiworld_lfmcmc].
+#' @examples
+#' ## Setup an SIR model to use in the simulation
+#' model_seed <- 122
+#' model_sir <- ModelSIR(name = "COVID-19", prevalence = .1,
+#'   transmission_rate = .9, recovery_rate = .3)
+#' agents_smallworld(
+#'   model_sir,
+#'   n = 1000,
+#'   k = 5,
+#'   d = FALSE,
+#'   p = 0.01
+#' )
+#' verbose_off(model_sir)
+#' run(model_sir, ndays = 50, seed = model_seed)
+#'
+#' ## Setup LFMCMC
+#' # Extract the observed data from the model
+#' obs_data <- unname(as.integer(get_today_total(model_sir)))
+#'
+#' # Define the simulation function
+#' simfun <- function(params) {
+#'   set_param(model_sir, "Recovery rate", params[1])
+#'   set_param(model_sir, "Transmission rate", params[2])
+#'   run(model_sir, ndays = 50)
+#'   res <- unname(as.integer(get_today_total(model_sir)))
+#'   return(res)
+#' }
+#'
+#' # Define the summary function
+#' sumfun <- function(dat) {
+#'   return(dat)
+#' }
+#'
+#' # Create the LFMCMC model
+#' lfmcmc_model <- LFMCMC(model_sir) |>
+#'   set_simulation_fun(simfun) |>
+#'   set_summary_fun(sumfun) |>
+#'   use_proposal_norm_reflective() |>
+#'   use_kernel_fun_gaussian() |>
+#'   set_observed_data(obs_data)
+#'
+#' ## Run LFMCMC simulation
+#' # Set initial parameters
+#' par0 <- as.double(c(0.1, 0.5))
+#' n_samp <- 2000
+#' epsil <- as.double(1.0)
+#'
+#' # Run the LFMCMC simulation
+#' run_lfmcmc(
+#'   lfmcmc = lfmcmc_model,
+#'   params_init_ = par0,
+#'   n_samples_ = n_samp,
+#'   epsilon_ = epsil,
+#'   seed = model_seed
+#' )
+#'
+#' # Print the results
+#' set_stats_names(lfmcmc_model, get_states(model_sir))
+#' set_par_names(lfmcmc_model, c("Immune recovery", "Infectiousness"))
+#'
+#' print(lfmcmc_model)
+#' @export
+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(model),
+    class = c("epiworld_lfmcmc")
+  )
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param params_init_ Initial model parameters
+#' @param n_samples_ Number of samples
+#' @param epsilon_ Epsilon parameter
+#' @param seed Random engine seed
+#' @returns The simulated model of class [epiworld_lfmcmc].
+#' @export
+run_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_, seed = NULL) UseMethod("run_lfmcmc")
+
+#' @export
+run_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_, seed = NULL) {
+  if (length(seed)) set.seed(seed)
+  run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_, sample.int(1e4, 1))
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param observed_data_ Observed data
+#' @returns The lfmcmc model with the observed data added
+#' @export
+set_observed_data <- function(lfmcmc, observed_data_) UseMethod("set_observed_data")
+
+#' @export
+set_observed_data.epiworld_lfmcmc <- function(lfmcmc, observed_data_) {
+  set_observed_data_cpp(lfmcmc, observed_data_)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param fun The LFMCMC proposal function
+#' @returns The lfmcmc model with the proposal function added
+#' @export
+set_proposal_fun <- function(lfmcmc, fun) UseMethod("set_proposal_fun")
+
+#' @export
+set_proposal_fun.epiworld_lfmcmc <- function(lfmcmc, fun) {
+  set_proposal_fun_cpp(lfmcmc, fun)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc The LFMCMC model
+#' @returns The LFMCMC model with proposal function set to norm reflective
+#' @export
+use_proposal_norm_reflective <- function(lfmcmc) {
+  use_proposal_norm_reflective_cpp(lfmcmc)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param fun The LFMCMC simulation function
+#' @returns The lfmcmc model with the simulation function added
+#' @export
+set_simulation_fun <- function(lfmcmc, fun) UseMethod("set_simulation_fun")
+
+#' @export
+set_simulation_fun.epiworld_lfmcmc <- function(lfmcmc, fun) {
+  set_simulation_fun_cpp(lfmcmc, fun)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param fun The LFMCMC sumamry function
+#' @returns The lfmcmc model with the summary function added
+#' @export
+set_summary_fun <- function(lfmcmc, fun) UseMethod("set_summary_fun")
+
+#' @export
+set_summary_fun.epiworld_lfmcmc <- function(lfmcmc, fun) {
+  set_summary_fun_cpp(lfmcmc, fun)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param fun The LFMCMC kernel function
+#' @returns The lfmcmc model with the kernel function added
+#' @export
+set_kernel_fun <- function(lfmcmc, fun) UseMethod("set_kernel_fun")
+
+#' @export
+set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) {
+  set_kernel_fun_cpp(lfmcmc, fun)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc The LFMCMC model
+#' @returns The LFMCMC model with kernel function set to gaussian
+#' @export
+use_kernel_fun_gaussian <- function(lfmcmc) {
+  use_kernel_fun_gaussian_cpp(lfmcmc)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param names The model parameter names
+#' @returns The lfmcmc model with the parameter names added
+#' @export
+set_par_names <- function(lfmcmc, names) UseMethod("set_par_names")
+
+#' @export
+set_par_names.epiworld_lfmcmc <- function(lfmcmc, names) {
+  set_par_names_cpp(lfmcmc, names)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param lfmcmc LFMCMC model
+#' @param names The model stats names
+#' @returns The lfmcmc model with the stats names added
+#' @export
+set_stats_names <- function(lfmcmc, names) UseMethod("set_stats_names")
+
+#' @export
+set_stats_names.epiworld_lfmcmc <- function(lfmcmc, names) {
+  set_stats_names_cpp(lfmcmc, names)
+  invisible(lfmcmc)
+}
+
+#' @rdname LFMCMC
+#' @param x LFMCMC model to print
+#' @param ... Ignored
+#' @returns The lfmcmc model
+#' @export
+print.epiworld_lfmcmc <- function(x, ...) {
+  print_lfmcmc_cpp(x)
+  invisible(x)
+}

R/cpp11.R

@@ -220,6 +220,54 @@ 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(model) {
+  .Call(`_epiworldR_LFMCMC_cpp`, model)
+}
+
+run_lfmcmc_cpp <- function(lfmcmc, params_init_, n_samples_, epsilon_, seed) {
+  .Call(`_epiworldR_run_lfmcmc_cpp`, lfmcmc, params_init_, n_samples_, epsilon_, seed)
+}
+
+set_observed_data_cpp <- function(lfmcmc, observed_data_) {
+  .Call(`_epiworldR_set_observed_data_cpp`, lfmcmc, observed_data_)
+}
+
+set_proposal_fun_cpp <- function(lfmcmc, fun) {
+  .Call(`_epiworldR_set_proposal_fun_cpp`, lfmcmc, fun)
+}
+
+use_proposal_norm_reflective_cpp <- function(lfmcmc) {
+  .Call(`_epiworldR_use_proposal_norm_reflective_cpp`, lfmcmc)
+}
+
+set_simulation_fun_cpp <- function(lfmcmc, fun) {
+  .Call(`_epiworldR_set_simulation_fun_cpp`, lfmcmc, fun)
+}
+
+set_summary_fun_cpp <- function(lfmcmc, fun) {
+  .Call(`_epiworldR_set_summary_fun_cpp`, lfmcmc, fun)
+}
+
+set_kernel_fun_cpp <- function(lfmcmc, fun) {
+  .Call(`_epiworldR_set_kernel_fun_cpp`, lfmcmc, fun)
+}
+
+use_kernel_fun_gaussian_cpp <- function(lfmcmc) {
+  .Call(`_epiworldR_use_kernel_fun_gaussian_cpp`, lfmcmc)
+}
+
+set_par_names_cpp <- function(lfmcmc, names) {
+  .Call(`_epiworldR_set_par_names_cpp`, lfmcmc, names)
+}
+
+set_stats_names_cpp <- function(lfmcmc, names) {
+  .Call(`_epiworldR_set_stats_names_cpp`, lfmcmc, names)
+}
+
+print_lfmcmc_cpp <- function(lfmcmc) {
+  .Call(`_epiworldR_print_lfmcmc_cpp`, lfmcmc)
+}
+
 print_cpp <- function(m, lite) {
   .Call(`_epiworldR_print_cpp`, m, lite)
 }

epiworldR.Rproj

@@ -14,5 +14,6 @@ LaTeX: pdfLaTeX
 
 BuildType: Package
 PackageUseDevtools: Yes
+PackageCleanBeforeInstall: No
 PackageInstallArgs: --no-multiarch --with-keep.source
 PackageRoxygenize: rd,collate,namespace