From ae2a80ff20db53c7a803a96165e50ebbe7a53929 Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 15 Oct 2024 09:16:03 -0600 Subject: [PATCH 01/70] Create LFMCMC.R and lfmcmc.cpp --- R/LFMCMC.R | 10 ++++++++++ src/lfmcmc.cpp | 17 +++++++++++++++++ 2 files changed, 27 insertions(+) create mode 100644 R/LFMCMC.R create mode 100644 src/lfmcmc.cpp diff --git a/R/LFMCMC.R b/R/LFMCMC.R new file mode 100644 index 00000000..f5c3ec81 --- /dev/null +++ b/R/LFMCMC.R @@ -0,0 +1,10 @@ +#' LFMCMC +#' +#' +#' @export +LFMCMC <- function() { + structure( + LFMCMC_cpp(), + # class = c("epiworld_surv", "epiworld_model") + ) +} \ No newline at end of file diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp new file mode 100644 index 00000000..7d68e56d --- /dev/null +++ b/src/lfmcmc.cpp @@ -0,0 +1,17 @@ +#include "cpp11.hpp" +#include "cpp11/external_pointer.hpp" + +#include "epiworld-common.h" + +// LFMCMC definitions: +// https://github.com/UofUEpiBio/epiworld/tree/master/include/epiworld/math/lfmcmc + +[[cpp11::register]] +SEXP LFMCMC_cpp() { + cpp11::external_pointer> lfmcmc_ptr( + new epiworld::LFMCMC<>() + ); + + return lfmcmc_ptr; +} + From bbdb724d28cc77651cb01d4c89186c4d225c8ba2 Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 15 Oct 2024 09:20:15 -0600 Subject: [PATCH 02/70] Fix pre-commit style failures --- R/LFMCMC.R | 2 +- src/lfmcmc.cpp | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index f5c3ec81..04b1b09b 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -7,4 +7,4 @@ LFMCMC <- function() { LFMCMC_cpp(), # class = c("epiworld_surv", "epiworld_model") ) -} \ No newline at end of file +} diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 7d68e56d..426f1630 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -14,4 +14,3 @@ SEXP LFMCMC_cpp() { return lfmcmc_ptr; } - From ab29fa1c764c9dff58565a162f6e7e8641e43f87 Mon Sep 17 00:00:00 2001 From: "George G. Vega Yon" Date: Tue, 15 Oct 2024 11:20:04 -0600 Subject: [PATCH 03/70] Using tidyverse 4.4.0 as base dev image --- .devcontainer/Dockerfile | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index 8ecd589d..1c71422e 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -1,21 +1,13 @@ -FROM rocker/r-devel:latest +FROM rocker/tidyverse:4.4.0 # RUN \ -# echo 'options(repos=c(CRAN="https://cloud.r-project.org"))' >> ~/.Rprofile && \ +# echo 'options(repos=c(CRAN="https://packagemanager.posit.co/cran/__linux__/bookworm/latest"))' >> ~/.Rprofile && \ # Rscript --vanilla -e 'getOption("repos")' -# Adding Git -RUN apt-get update && apt-get install -y --no-install-recommends git - # Adding R packages -RUN \ - wget https://github.com/jgm/pandoc/releases/download/3.2.1/pandoc-3.2.1-1-amd64.deb && \ - dpkg -i pandoc-3.2.1-1-amd64.deb - -RUN install2.r cpp11 rmarkdown roxygen2 tinytest data.table netplot \ - devtools +RUN install2.r cpp11 roxygen2 tinytest data.table netplot \ + devtools decor -RUN apt-get install -y --no-install-recommends && \ - install2.r languageserver +RUN install2.r languageserver CMD ["bash"] From 7d2de7809919a091463795020090087b5e1be199 Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 15 Oct 2024 13:04:34 -0600 Subject: [PATCH 04/70] Fix roxygenize typo in Makefile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 7e0f0bbd..a3000888 100644 --- a/Makefile +++ b/Makefile @@ -46,7 +46,7 @@ clean: sed -i -E 's/^library\(epiworldRdev\)/library(epiworldR)/g' README.* docs: - Rscript --vanilla -e 'roxygen2::roxigenize()' + Rscript --vanilla -e 'roxygen2::roxygenize()' .PHONY: build update check clean docs docker-debug From 037aef69075cc626b21474d6bd1d2b3d60a591c7 Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 15 Oct 2024 13:16:26 -0600 Subject: [PATCH 05/70] Run 'make docs' and add cpp11, NAMESPACE, and roxygen files --- NAMESPACE | 1 + R/LFMCMC.R | 2 +- R/cpp11.R | 4 ++++ man/LFMCMC.Rd | 11 +++++++++++ src/cpp11.cpp | 8 ++++++++ src/lfmcmc.cpp | 4 ++-- 6 files changed, 27 insertions(+), 3 deletions(-) create mode 100644 man/LFMCMC.Rd diff --git a/NAMESPACE b/NAMESPACE index 17f23b74..edfc20fd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -80,6 +80,7 @@ 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) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 04b1b09b..4991958d 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -5,6 +5,6 @@ LFMCMC <- function() { structure( LFMCMC_cpp(), - # class = c("epiworld_surv", "epiworld_model") + class = c("epiworld_lfmcmc") ) } diff --git a/R/cpp11.R b/R/cpp11.R index b1276fdb..a4f19ea6 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -220,6 +220,10 @@ 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`) +} + print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd new file mode 100644 index 00000000..c2619442 --- /dev/null +++ b/man/LFMCMC.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/LFMCMC.R +\name{LFMCMC} +\alias{LFMCMC} +\title{LFMCMC} +\usage{ +LFMCMC() +} +\description{ +LFMCMC +} diff --git a/src/cpp11.cpp b/src/cpp11.cpp index b8ad0851..876892dd 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -390,6 +390,13 @@ extern "C" SEXP _epiworldR_ModelSEIRMixing_cpp(SEXP name, SEXP n, SEXP prevalenc return cpp11::as_sexp(ModelSEIRMixing_cpp(cpp11::as_cpp>(name), cpp11::as_cpp>(n), cpp11::as_cpp>(prevalence), cpp11::as_cpp>(contact_rate), cpp11::as_cpp>(transmission_rate), cpp11::as_cpp>(incubation_days), cpp11::as_cpp>(recovery_rate), cpp11::as_cpp>>(contact_matrix))); END_CPP11 } +// lfmcmc.cpp +SEXP LFMCMC_cpp(); +extern "C" SEXP _epiworldR_LFMCMC_cpp() { + BEGIN_CPP11 + return cpp11::as_sexp(LFMCMC_cpp()); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -911,6 +918,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_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}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 426f1630..270e8de1 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -8,8 +8,8 @@ [[cpp11::register]] SEXP LFMCMC_cpp() { - cpp11::external_pointer> lfmcmc_ptr( - new epiworld::LFMCMC<>() + cpp11::external_pointer>> lfmcmc_ptr( + new epiworld::LFMCMC>() ); return lfmcmc_ptr; From 4c181256dcd4dc90703172821b09df6acbaac21e Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 15 Oct 2024 13:16:57 -0600 Subject: [PATCH 06/70] Add config.log and config.status to gitignore --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index bc64c2f6..eb777ffc 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,6 @@ src/Makevars images inst/doc docs + +config.log +config.status From 08e677b5f3c30cfc35f66dd443c1ac11c67ed4ff Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 15 Oct 2024 13:17:32 -0600 Subject: [PATCH 07/70] Run pre-commit on existing docs files --- man/ModelDiffNet.Rd | 4 +- man/ModelSEIR.Rd | 8 +-- man/ModelSEIRCONN.Rd | 10 ++-- man/ModelSEIRD.Rd | 10 ++-- man/ModelSEIRDCONN.Rd | 10 ++-- man/ModelSIR.Rd | 8 +-- man/ModelSIRCONN.Rd | 2 +- man/ModelSIRD.Rd | 14 ++--- man/ModelSIRDCONN.Rd | 2 +- man/ModelSIRLogit.Rd | 16 +++--- man/ModelSIS.Rd | 8 +-- man/ModelSISD.Rd | 16 +++--- man/ModelSURV.Rd | 6 +- man/agents.Rd | 36 ++++++------ man/agents_smallworld.Rd | 22 ++++---- man/entities.Rd | 14 ++--- man/epiworld-data.Rd | 10 ++-- man/epiworld-methods.Rd | 116 +++++++++++++++++++-------------------- man/epiworldR-package.Rd | 4 +- man/global-actions.Rd | 10 ++-- man/run_multiple.Rd | 4 +- man/tool.Rd | 25 +++++---- man/virus.Rd | 19 +++---- 23 files changed, 187 insertions(+), 187 deletions(-) diff --git a/man/ModelDiffNet.Rd b/man/ModelDiffNet.Rd index e8ed956c..83c6fefd 100644 --- a/man/ModelDiffNet.Rd +++ b/man/ModelDiffNet.Rd @@ -67,8 +67,8 @@ n <- 10000 # Generating synthetic data on a matrix with 2 columns. X <- cbind( - age = sample(1:100, n, replace = TRUE), - female = sample.int(2, n, replace = TRUE) - 1 + age = sample(1:100, n, replace = TRUE), + female = sample.int(2, n, replace = TRUE) - 1 ) adopt_chatgpt <- ModelDiffNet( diff --git a/man/ModelSEIR.Rd b/man/ModelSEIR.Rd index 8f8f4958..d161e9b5 100644 --- a/man/ModelSEIR.Rd +++ b/man/ModelSEIR.Rd @@ -47,8 +47,8 @@ values: (1) Proportion of non-infected agents who are removed, and (2) Proportion of exposed agents to be set as infected. } \examples{ -model_seir <- ModelSEIR(name = "COVID-19", prevalence = 0.01, -transmission_rate = 0.9, recovery_rate = 0.1, incubation_days = 4) +model_seir <- ModelSEIR(name = "COVID-19", prevalence = 0.01, + transmission_rate = 0.9, recovery_rate = 0.1, incubation_days = 4) # Adding a small world population agents_smallworld( @@ -57,8 +57,8 @@ agents_smallworld( k = 5, d = FALSE, p = .01 - ) - +) + # Running and printing run(model_seir, ndays = 100, seed = 1912) model_seir diff --git a/man/ModelSEIRCONN.Rd b/man/ModelSEIRCONN.Rd index c885d54c..1a3cb966 100644 --- a/man/ModelSEIRCONN.Rd +++ b/man/ModelSEIRCONN.Rd @@ -57,14 +57,14 @@ This is equivalent to a compartmental model (\href{https://en.wikipedia.org/w/in # An example with COVID-19 model_seirconn <- ModelSEIRCONN( name = "COVID-19", - prevalence = 0.01, + prevalence = 0.01, n = 10000, - contact_rate = 2, - incubation_days = 7, + contact_rate = 2, + incubation_days = 7, transmission_rate = 0.5, recovery_rate = 0.3 ) - + # Running and printing run(model_seirconn, ndays = 100, seed = 1912) model_seirconn @@ -72,7 +72,7 @@ model_seirconn plot(model_seirconn) # Adding the flu -flu <- virus("Flu", .9, 1/7, prevalence = 0.001, as_proportion = TRUE) +flu <- virus("Flu", .9, 1 / 7, prevalence = 0.001, as_proportion = TRUE) add_virus(model_seirconn, flu) #' # Running and printing diff --git a/man/ModelSEIRD.Rd b/man/ModelSEIRD.Rd index c32c3496..0f3e83c3 100644 --- a/man/ModelSEIRD.Rd +++ b/man/ModelSEIRD.Rd @@ -57,9 +57,9 @@ proportion of non-infected agents already removed, and (3) proportion of non-ifected agents already deceased. } \examples{ -model_seird <- ModelSEIRD(name = "COVID-19", prevalence = 0.01, -transmission_rate = 0.9, recovery_rate = 0.1, incubation_days = 4, -death_rate = 0.01) +model_seird <- ModelSEIRD(name = "COVID-19", prevalence = 0.01, + transmission_rate = 0.9, recovery_rate = 0.1, incubation_days = 4, + death_rate = 0.01) # Adding a small world population agents_smallworld( @@ -68,8 +68,8 @@ agents_smallworld( k = 5, d = FALSE, p = .01 - ) - +) + # Running and printing run(model_seird, ndays = 100, seed = 1912) model_seird diff --git a/man/ModelSEIRDCONN.Rd b/man/ModelSEIRDCONN.Rd index bb535114..c3db3dc8 100644 --- a/man/ModelSEIRDCONN.Rd +++ b/man/ModelSEIRDCONN.Rd @@ -67,15 +67,15 @@ non-ifected agents already deceased. # An example with COVID-19 model_seirdconn <- ModelSEIRDCONN( name = "COVID-19", - prevalence = 0.01, + prevalence = 0.01, n = 10000, - contact_rate = 2, - incubation_days = 7, + contact_rate = 2, + incubation_days = 7, transmission_rate = 0.5, recovery_rate = 0.3, death_rate = 0.01 ) - + # Running and printing run(model_seirdconn, ndays = 100, seed = 1912) model_seirdconn @@ -84,7 +84,7 @@ plot(model_seirdconn) # Adding the flu flu <- virus( - "Flu", prob_infecting = .3, recovery_rate = 1/7, + "Flu", prob_infecting = .3, recovery_rate = 1 / 7, prob_death = 0.001, prevalence = 0.001, as_proportion = TRUE ) diff --git a/man/ModelSIR.Rd b/man/ModelSIR.Rd index eafb9a3c..6312ccd7 100644 --- a/man/ModelSIR.Rd +++ b/man/ModelSIR.Rd @@ -45,8 +45,8 @@ model. In particular, the user can specify how many of the non-infected agents have been removed at the beginning of the simulation. } \examples{ -model_sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, - transmission_rate = 0.9, recovery_rate = 0.1) +model_sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, + transmission_rate = 0.9, recovery_rate = 0.1) # Adding a small world population agents_smallworld( @@ -55,8 +55,8 @@ agents_smallworld( k = 5, d = FALSE, p = .01 - ) - +) + # Running and printing run(model_sir, ndays = 100, seed = 1912) model_sir diff --git a/man/ModelSIRCONN.Rd b/man/ModelSIRCONN.Rd index e6e21556..4e867bb7 100644 --- a/man/ModelSIRCONN.Rd +++ b/man/ModelSIRCONN.Rd @@ -62,7 +62,7 @@ model_sirconn <- ModelSIRCONN( transmission_rate = 0.4, recovery_rate = 0.95 ) - + # Running and printing run(model_sirconn, ndays = 100, seed = 1912) model_sirconn diff --git a/man/ModelSIRD.Rd b/man/ModelSIRD.Rd index c2b92ca0..ddda5479 100644 --- a/man/ModelSIRD.Rd +++ b/man/ModelSIRD.Rd @@ -49,11 +49,11 @@ non-ifected agents already deceased. } \examples{ model_sird <- ModelSIRD( - name = "COVID-19", - prevalence = 0.01, - transmission_rate = 0.9, - recovery_rate = 0.1, - death_rate = 0.01 + name = "COVID-19", + prevalence = 0.01, + transmission_rate = 0.9, + recovery_rate = 0.1, + death_rate = 0.01 ) # Adding a small world population @@ -63,8 +63,8 @@ agents_smallworld( k = 5, d = FALSE, p = .01 - ) - +) + # Running and printing run(model_sird, ndays = 100, seed = 1912) model_sird diff --git a/man/ModelSIRDCONN.Rd b/man/ModelSIRDCONN.Rd index 717d7321..cd48e99c 100644 --- a/man/ModelSIRDCONN.Rd +++ b/man/ModelSIRDCONN.Rd @@ -67,7 +67,7 @@ model_sirdconn <- ModelSIRDCONN( recovery_rate = 0.5, death_rate = 0.1 ) - + # Running and printing run(model_sirdconn, ndays = 100, seed = 1912) model_sirdconn diff --git a/man/ModelSIRLogit.Rd b/man/ModelSIRLogit.Rd index 3201c78c..ce9f3d44 100644 --- a/man/ModelSIRLogit.Rd +++ b/man/ModelSIRLogit.Rd @@ -47,10 +47,10 @@ SIR Logistic model set.seed(2223) n <- 100000 -# Creating the data to use for the "ModelSIRLogit" function. It contains -# information on the sex of each agent and will be used to determine -# differences in disease progression between males and females. Note that -# the number of rows in these data are identical to n (100000). +# Creating the data to use for the "ModelSIRLogit" function. It contains +# information on the sex of each agent and will be used to determine +# differences in disease progression between males and females. Note that +# the number of rows in these data are identical to n (100000). X <- cbind( Intercept = 1, Female = sample.int(2, n, replace = TRUE) - 1 @@ -60,12 +60,12 @@ X <- cbind( coef_infect <- c(.1, -2, 2) coef_recover <- rnorm(2) -# Feed all above information into the "ModelSIRLogit" function. +# Feed all above information into the "ModelSIRLogit" function. model_logit <- ModelSIRLogit( "covid2", data = X, coefs_infect = coef_infect, - coefs_recover = coef_recover, + coefs_recover = coef_recover, coef_infect_cols = 1L:ncol(X), coef_recover_cols = 1L:ncol(X), prob_infection = .8, @@ -82,11 +82,11 @@ plot(model_logit) # Females are supposed to be more likely to become infected. rn <- get_reproductive_number(model_logit) -# Probability of infection for males and females. +# Probability of infection for males and females. (table( X[, "Female"], (1:n \%in\% rn$source) -) |> prop.table())[,2] +) |> prop.table())[, 2] # Looking into the individual agents. get_agents(model_logit) diff --git a/man/ModelSIS.Rd b/man/ModelSIS.Rd index 8b0a8994..f671b2a2 100644 --- a/man/ModelSIS.Rd +++ b/man/ModelSIS.Rd @@ -40,8 +40,8 @@ infection.} Susceptible-Infected-Susceptible model (SIS) (\href{https://en.wikipedia.org/w/index.php?title=Compartmental_models_in_epidemiology&oldid=1155757336#The_SIS_model}{wiki}) } \examples{ -model_sis <- ModelSIS(name = "COVID-19", prevalence = 0.01, - transmission_rate = 0.9, recovery_rate = 0.1) +model_sis <- ModelSIS(name = "COVID-19", prevalence = 0.01, + transmission_rate = 0.9, recovery_rate = 0.1) # Adding a small world population agents_smallworld( @@ -50,8 +50,8 @@ agents_smallworld( k = 5, d = FALSE, p = .01 - ) - +) + # Running and printing run(model_sis, ndays = 100, seed = 1912) model_sis diff --git a/man/ModelSISD.Rd b/man/ModelSISD.Rd index 4e164ab5..835a87de 100644 --- a/man/ModelSISD.Rd +++ b/man/ModelSISD.Rd @@ -43,12 +43,12 @@ Susceptible-Infected-Susceptible-Deceased model (SISD) (\href{https://en.wikiped } \examples{ model_sisd <- ModelSISD( - name = "COVID-19", - prevalence = 0.01, - transmission_rate = 0.9, - recovery_rate = 0.1, - death_rate = 0.01 - ) + name = "COVID-19", + prevalence = 0.01, + transmission_rate = 0.9, + recovery_rate = 0.1, + death_rate = 0.01 +) # Adding a small world population agents_smallworld( @@ -57,8 +57,8 @@ agents_smallworld( k = 5, d = FALSE, p = .01 - ) - +) + # Running and printing run(model_sisd, ndays = 100, seed = 1912) model_sisd diff --git a/man/ModelSURV.Rd b/man/ModelSURV.Rd index 90dc9aa8..796694f7 100644 --- a/man/ModelSURV.Rd +++ b/man/ModelSURV.Rd @@ -99,11 +99,11 @@ agents_smallworld( k = 5, d = FALSE, p = .01 - ) - +) + # Running and printing run(model_surv, ndays = 100, seed = 1912) -model_surv +model_surv # Plotting plot(model_surv, main = "SURV Model") diff --git a/man/agents.Rd b/man/agents.Rd index f5d7e74b..9375c4ff 100644 --- a/man/agents.Rd +++ b/man/agents.Rd @@ -64,29 +64,29 @@ contains all the information about the agents in the model. The And the \code{get_state} function returns the state of a single agent. } \examples{ - + model_sirconn <- ModelSIRCONN( -name = "COVID-19", -n = 10000, -prevalence = 0.01, -contact_rate = 5, -transmission_rate = 0.4, -recovery_rate = 0.95 + name = "COVID-19", + n = 10000, + prevalence = 0.01, + contact_rate = 5, + transmission_rate = 0.4, + recovery_rate = 0.95 ) run(model_sirconn, ndays = 100, seed = 1912) -x <- get_agents(model_sirconn) # Storing all agent information into object of - # class epiworld_agents - -print(x, compressed = FALSE, max_print = 5) # Displaying detailed information of - # the first 5 agents using - # compressed=F. Using compressed=T - # results in less-detailed - # information about each agent. - -x[0] # Print information about the first agent. Substitute the agent of - # interest's position where '0' is. +x <- get_agents(model_sirconn) # Storing all agent information into object of +# class epiworld_agents + +print(x, compressed = FALSE, max_print = 5) # Displaying detailed information of +# the first 5 agents using +# compressed=F. Using compressed=T +# results in less-detailed +# information about each agent. + +x[0] # Print information about the first agent. Substitute the agent of +# interest's position where '0' is. } \seealso{ agents diff --git a/man/agents_smallworld.Rd b/man/agents_smallworld.Rd index 36717930..12036208 100644 --- a/man/agents_smallworld.Rd +++ b/man/agents_smallworld.Rd @@ -113,15 +113,15 @@ provided, the agent will be updated with the default values of the virus/tool. \examples{ # Initializing SIR model with agents_smallworld -sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, transmission_rate = 0.9, - recovery_rate = 0.1) +sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, transmission_rate = 0.9, + recovery_rate = 0.1) agents_smallworld( - sir, - n = 1000, - k = 5, - d = FALSE, - p = .01 - ) + sir, + n = 1000, + k = 5, + d = FALSE, + p = .01 +) run(sir, ndays = 100, seed = 1912) sir @@ -132,7 +132,7 @@ head(net) # Simulating a bernoulli graph set.seed(333) n <- 1000 -g <- matrix(runif(n ^ 2) < .01, nrow = n) +g <- matrix(runif(n^2) < .01, nrow = n) diag(g) <- FALSE el <- which(g, arr.ind = TRUE) - 1L @@ -141,8 +141,8 @@ el <- which(g, arr.ind = TRUE) - 1L sir <- ModelSIR("COVID-19", .01, .8, .3) agents_from_edgelist( sir, - source = el[,1], - target = el[,2], + source = el[, 1], + target = el[, 2], size = n, directed = TRUE ) diff --git a/man/entities.Rd b/man/entities.Rd index 9f0724d2..1f0be67d 100644 --- a/man/entities.Rd +++ b/man/entities.Rd @@ -114,13 +114,13 @@ Epiworld entities are especially useful for mixing models, particularly \examples{ # Creating a mixing model mymodel <- ModelSIRMixing( - name = "My model", - n = 10000, - prevalence = .001, - contact_rate = 10, - transmission_rate = .1, - recovery_rate = 1/7, - contact_matrix = matrix(c(.9, .1, .1, .9), 2, 2) + name = "My model", + n = 10000, + prevalence = .001, + contact_rate = 10, + transmission_rate = .1, + recovery_rate = 1 / 7, + contact_matrix = matrix(c(.9, .1, .1, .9), 2, 2) ) ent1 <- entity("First", 5000, FALSE) diff --git a/man/epiworld-data.Rd b/man/epiworld-data.Rd index 3390eee0..148de4f1 100644 --- a/man/epiworld-data.Rd +++ b/man/epiworld-data.Rd @@ -193,7 +193,7 @@ seirconn <- ModelSEIRCONN( name = "Disease", n = 10000, prevalence = 0.1, - contact_rate = 2.0, + contact_rate = 2.0, transmission_rate = 0.8, incubation_days = 7.0, recovery_rate = 0.3 @@ -204,12 +204,12 @@ set.seed(937) run(seirconn, 50) # Retrieving the transition probability -get_transition_probability(seirconn) +get_transition_probability(seirconn) -# Retrieving date, state, and counts dataframe including any added tools +# Retrieving date, state, and counts dataframe including any added tools get_hist_tool(seirconn) -# Retrieving overall date, state, and counts dataframe +# Retrieving overall date, state, and counts dataframe head(get_hist_total(seirconn)) # Retrieving date, state, and counts dataframe by variant @@ -225,7 +225,7 @@ t_hist <- get_hist_transition_matrix(seirconn) head(t_hist) # And turn it into an array -as.array(t_hist)[,,1:3] +as.array(t_hist)[, , 1:3] # We cam also get (and plot) the incidence, as well as # the generation time diff --git a/man/epiworld-methods.Rd b/man/epiworld-methods.Rd index 3d5deab2..7b703c8a 100644 --- a/man/epiworld-methods.Rd +++ b/man/epiworld-methods.Rd @@ -199,79 +199,79 @@ the assignment operator will only copy the pointer. \examples{ model_sirconn <- ModelSIRCONN( -name = "COVID-19", -n = 10000, -prevalence = 0.01, -contact_rate = 5, -transmission_rate = 0.4, -recovery_rate = 0.95 + name = "COVID-19", + n = 10000, + prevalence = 0.01, + contact_rate = 5, + transmission_rate = 0.4, + recovery_rate = 0.95 ) -# Queuing - If you wish to implement the queuing function, declare whether -# you would like it "on" or "off", if any. +# Queuing - If you wish to implement the queuing function, declare whether +# you would like it "on" or "off", if any. queuing_on(model_sirconn) queuing_off(model_sirconn) run(model_sirconn, ndays = 100, seed = 1912) -# Verbose - "on" prints the progress bar on the screen while "off" -# deactivates the progress bar. Declare which function you want to implement, -# if any. +# Verbose - "on" prints the progress bar on the screen while "off" +# deactivates the progress bar. Declare which function you want to implement, +# if any. verbose_on(model_sirconn) verbose_off(model_sirconn) run(model_sirconn, ndays = 100, seed = 1912) get_states(model_sirconn) # Returns all unique states found within the model. -get_param(model_sirconn, 'Contact rate') # Returns the value of the selected - # parameter within the model object. - # In order to view the parameters, - # run the model object and find the - # "Model parameters" section. - -set_param(model_sirconn, 'Contact rate', 2) # Allows for adjustment of model - # parameters within the model - # object. In this example, the - # Contact rate parameter is - # changed to 2. You can now rerun - # the model to observe any - # differences. - -set_name(model_sirconn, 'My Epi-Model') # This function allows for setting - # a name for the model. Running the - # model object, the name of the model - # is now reflected next to "Name of - # the model". - -get_name(model_sirconn) # Returns the set name of the model. - -get_n_viruses(model_sirconn) # Returns the number of viruses in the model. - # In this case, there is only one virus: - # "COVID-19". - -get_n_tools(model_sirconn) # Returns the number of tools in the model. In - # this case, there are zero tools. - +get_param(model_sirconn, "Contact rate") # Returns the value of the selected +# parameter within the model object. +# In order to view the parameters, +# run the model object and find the +# "Model parameters" section. + +set_param(model_sirconn, "Contact rate", 2) # Allows for adjustment of model +# parameters within the model +# object. In this example, the +# Contact rate parameter is +# changed to 2. You can now rerun +# the model to observe any +# differences. + +set_name(model_sirconn, "My Epi-Model") # This function allows for setting +# a name for the model. Running the +# model object, the name of the model +# is now reflected next to "Name of +# the model". + +get_name(model_sirconn) # Returns the set name of the model. + +get_n_viruses(model_sirconn) # Returns the number of viruses in the model. +# In this case, there is only one virus: +# "COVID-19". + +get_n_tools(model_sirconn) # Returns the number of tools in the model. In +# this case, there are zero tools. + get_ndays(model_sirconn) # Returns the length of the simulation in days. This - # will match "ndays" within the "run" function. - -get_n_replicates(model_sirconn) # Returns the number of replicates of the - # model. - -size(model_sirconn) # Returns the population size in the model. In this case, - # there are 10,000 agents in the model. +# will match "ndays" within the "run" function. + +get_n_replicates(model_sirconn) # Returns the number of replicates of the +# model. + +size(model_sirconn) # Returns the population size in the model. In this case, +# there are 10,000 agents in the model. # Set Agents Data -# First, your data matrix must have the same number of rows as agents in the -# model. Below is a generated matrix which will be passed into the -# "set_agents_data" function. -data <- matrix(data=runif(20000, min=0, max=100), nrow=10000, ncol=2) +# First, your data matrix must have the same number of rows as agents in the +# model. Below is a generated matrix which will be passed into the +# "set_agents_data" function. +data <- matrix(data = runif(20000, min = 0, max = 100), nrow = 10000, ncol = 2) set_agents_data(model_sirconn, data) -get_agents_data_ncols(model_sirconn) # Returns number of columns +get_agents_data_ncols(model_sirconn) # Returns number of columns -get_virus(model_sirconn, 0) # Returns information about the first virus in - # the model (index begins at 0). +get_virus(model_sirconn, 0) # Returns information about the first virus in +# the model (index begins at 0). -add_tool(model_sirconn, tool("Vaccine", .9, .9, .5, 1, prevalence = 0.5, as_prop = TRUE)) -get_tool(model_sirconn, 0) # Returns information about the first tool in the - # model. In this case, there are no tools so an - # error message will occur. +add_tool(model_sirconn, tool("Vaccine", .9, .9, .5, 1, prevalence = 0.5, as_prop = TRUE)) +get_tool(model_sirconn, 0) # Returns information about the first tool in the +# model. In this case, there are no tools so an +# error message will occur. } diff --git a/man/epiworldR-package.Rd b/man/epiworldR-package.Rd index 1d594f7a..33015655 100644 --- a/man/epiworldR-package.Rd +++ b/man/epiworldR-package.Rd @@ -19,11 +19,11 @@ Useful links: } \author{ -\strong{Maintainer}: Derek Meyer \email{derekmeyer37@gmail.com} (\href{https://orcid.org/0009-0005-1350-6988}{ORCID}) +\strong{Maintainer}: George Vega Yon \email{g.vegayon@gmail.com} (\href{https://orcid.org/0000-0002-3171-0844}{ORCID}) Authors: \itemize{ - \item George Vega Yon \email{g.vegayon@gmail.com} (\href{https://orcid.org/0000-0002-3171-0844}{ORCID}) + \item Derek Meyer \email{derekmeyer37@gmail.com} (\href{https://orcid.org/0009-0005-1350-6988}{ORCID}) } Other contributors: diff --git a/man/global-actions.Rd b/man/global-actions.Rd index dd4c819e..e47f02b9 100644 --- a/man/global-actions.Rd +++ b/man/global-actions.Rd @@ -117,7 +117,7 @@ epitool <- tool( as_proportion = FALSE, susceptibility_reduction = .9, transmission_reduction = .5, - recovery_enhancer = .5, + recovery_enhancer = .5, death_reduction = .9 ) @@ -159,7 +159,7 @@ model <- ModelSIRCONN( contact_rate = 5, transmission_rate = 0.4, recovery_rate = 0.3 - ) +) # We create the object where the history of the agents will be stored agents_history <- NULL @@ -167,7 +167,7 @@ agents_history <- NULL # This function prints the total number of agents in each state # and stores the history of the agents in the object `agents_history` hist_saver <- function(m) { - + message("Today's totals are: ", paste(get_today_total(m), collapse = ", ")) # We use the `<<-` operator to assign the value to the global variable @@ -175,8 +175,8 @@ hist_saver <- function(m) { agents_history <<- cbind( agents_history, get_agents_states(m) - ) - + ) + } } \seealso{ diff --git a/man/run_multiple.Rd b/man/run_multiple.Rd index 8d736f5b..dc308dc0 100644 --- a/man/run_multiple.Rd +++ b/man/run_multiple.Rd @@ -80,7 +80,7 @@ model_sir <- ModelSIRCONN( n = 1000, contact_rate = 2, transmission_rate = 0.9, recovery_rate = 0.1 - ) +) # Generating a saver saver <- make_saver("total_hist", "reproductive") @@ -96,7 +96,7 @@ head(ans$reproductive) # Plotting multi_sir <- run_multiple_get_results(model_sir)$total_hist -multi_sir <- multi_sir[multi_sir$date <= 20,] +multi_sir <- multi_sir[multi_sir$date <= 20, ] plot(multi_sir) } diff --git a/man/tool.Rd b/man/tool.Rd index f5beaa0c..0e0d3090 100644 --- a/man/tool.Rd +++ b/man/tool.Rd @@ -225,13 +225,13 @@ epitool <- tool( as_proportion = TRUE, susceptibility_reduction = .9, transmission_reduction = .5, - recovery_enhancer = .5, + recovery_enhancer = .5, death_reduction = .9 ) epitool -set_name_tool(epitool, 'Pfizer') # Assigning name to the tool +set_name_tool(epitool, "Pfizer") # Assigning name to the tool get_name_tool(epitool) # Returning the name of the tool add_tool(model_sirconn, epitool) run(model_sirconn, ndays = 100, seed = 1912) @@ -246,21 +246,21 @@ add_tool(model_sirconn, epitool) run(model_sirconn, ndays = 100, seed = 1912) # Adjusting probabilities due to tool -set_susceptibility_reduction(epitool, 0.1) # Susceptibility reduction +set_susceptibility_reduction(epitool, 0.1) # Susceptibility reduction set_transmission_reduction(epitool, 0.2) # Transmission reduction set_recovery_enhancer(epitool, 0.15) # Probability increase of recovery set_death_reduction(epitool, 0.05) # Probability reduction of death -rm_tool(model_sirconn, 0) +rm_tool(model_sirconn, 0) add_tool(model_sirconn, epitool) run(model_sirconn, ndays = 100, seed = 1912) # Run model to view changes # Using the logit function -------------- sir <- ModelSIR( - name = "COVID-19", prevalence = 0.01, + name = "COVID-19", prevalence = 0.01, transmission_rate = 0.9, recovery_rate = 0.1 - ) +) # Adding a small world population agents_smallworld( @@ -303,7 +303,7 @@ tfun <- tool_fun_logit( ) # The infection prob is lower -hist(plogis(dat \%*\% rbind(.5,1))) +hist(plogis(dat \%*\% rbind(.5, 1))) tfun # printing @@ -312,15 +312,16 @@ set_susceptibility_reduction_fun( tool = get_tool(sir, 0), model = sir, tfun = tfun - ) - +) + run(sir, ndays = 50, seed = 11) hist_1 <- get_hist_total(sir) op <- par(mfrow = c(1, 2)) -plot(hist_0); abline(v = 30) -plot(hist_1); abline(v = 30) +plot(hist_0) +abline(v = 30) +plot(hist_1) +abline(v = 30) par(op) - } diff --git a/man/virus.Rd b/man/virus.Rd index b911a4ef..d456690c 100644 --- a/man/virus.Rd +++ b/man/virus.Rd @@ -209,10 +209,10 @@ passed to \code{set_distribution_virus}. \examples{ mseirconn <- ModelSEIRCONN( name = "COVID-19", - prevalence = 0.01, + prevalence = 0.01, n = 10000, - contact_rate = 4, - incubation_days = 7, + contact_rate = 4, + incubation_days = 7, transmission_rate = 0.5, recovery_rate = 0.99 ) @@ -231,7 +231,7 @@ mseirconn rm_virus(mseirconn, 0) # Removing the first virus from the model object set_distribution_virus(delta, distribute_virus_randomly(100, as_proportion = FALSE)) -add_virus(mseirconn, delta) +add_virus(mseirconn, delta) # Setting parameters for the delta virus manually set_prob_infecting(delta, 0.5) @@ -249,9 +249,9 @@ delta2 <- virus( virus_set_state(delta2, 1, 2, 3) # Using the logit function -------------- sir <- ModelSIR( - name = "COVID-19", prevalence = 0.01, + name = "COVID-19", prevalence = 0.01, transmission_rate = 0.9, recovery = 0.1 - ) +) # Adding a small world population agents_smallworld( @@ -281,7 +281,7 @@ vfun <- virus_fun_logit( ) # The infection prob is lower -hist(plogis(dat \%*\% rbind(-1,1))) +hist(plogis(dat \%*\% rbind(-1, 1))) vfun # printing @@ -289,10 +289,9 @@ set_prob_infecting_fun( virus = get_virus(sir, 0), model = sir, vfun = vfun - ) - +) + run(sir, ndays = 50, seed = 11) plot(sir) - } From b57e6cc26269a527b904d768cf6b96503cac1f75 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 16 Oct 2024 11:37:19 -0600 Subject: [PATCH 08/70] Add epiworld_double macro to Makevars --- src/Makevars.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makevars.in b/src/Makevars.in index fc3bb29e..845e17c4 100644 --- a/src/Makevars.in +++ b/src/Makevars.in @@ -1,3 +1,3 @@ PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) @OPENMP_FLAG@ PKG_CXXFLAGS=@OPENMP_FLAG@ -I../inst/include/ $(EPI_CONFIG) \ - -Dprintf_epiworld=Rprintf + -Dprintf_epiworld=Rprintf -Depiworld_double=double From c3d529f48049050dd84f7ae097a21590f4f76c1a Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 16 Oct 2024 11:37:55 -0600 Subject: [PATCH 09/70] Add run method to LFMCMC --- NAMESPACE | 1 + R/LFMCMC.R | 42 ++++++++++++++++++++++++++ R/cpp11.R | 4 +++ src/cpp11.cpp | 8 +++++ src/lfmcmc.cpp | 81 ++++++++++++++++++++++++++++++++++++++++++++++++-- 5 files changed, 134 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index edfc20fd..d5ffc903 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -72,6 +72,7 @@ S3method(queuing_off,epiworld_model) S3method(queuing_on,epiworld_model) S3method(queuing_on,epiworld_seirconn) S3method(queuing_on,epiworld_sirconn) +S3method(run,epiworld_lfmcmc) S3method(run,epiworld_model) S3method(run_multiple,epiworld_model) S3method(set_name,epiworld_model) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 4991958d..cb739557 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -8,3 +8,45 @@ LFMCMC <- function() { class = c("epiworld_lfmcmc") ) } + +#' @export +run.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { + run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) + invisible(lfmcmc) +} + +# #' @export +# run.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { +# run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) +# invisible(lfmcmc) +# } + +# #' @export +# set_observed_data.epiworld_lfmcmc <- function(lfmcmc, observed_data_) { +# set_observed_data_cpp(lfmcmc, observed_data_) +# invisible(lfmcmc) +# } + +# #' @export +# set_proposal_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { +# set_proposal_fun_cpp(lfmcmc, fun) +# invisible(lfmcmc) +# } + +# #' @export +# set_simulation_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { +# set_simulation_fun_cpp(lfmcmc, fun) +# invisible(lfmcmc) +# } + +# #' @export +# set_summary_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { +# set_summary_fun_cpp(lfmcmc, fun) +# invisible(lfmcmc) +# } + +# #' @export +# set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { +# set_kernel_fun_cpp(lfmcmc, fun) +# invisible(lfmcmc) +# } diff --git a/R/cpp11.R b/R/cpp11.R index a4f19ea6..6e60fcaf 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -224,6 +224,10 @@ LFMCMC_cpp <- function() { .Call(`_epiworldR_LFMCMC_cpp`) } +run_lfmcmc_cpp <- function(lfmcmc, params_init_, n_samples_, epsilon_) { + .Call(`_epiworldR_run_lfmcmc_cpp`, lfmcmc, params_init_, n_samples_, epsilon_) +} + print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 876892dd..5da0d3ba 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -397,6 +397,13 @@ extern "C" SEXP _epiworldR_LFMCMC_cpp() { return cpp11::as_sexp(LFMCMC_cpp()); END_CPP11 } +// lfmcmc.cpp +SEXP run_lfmcmc_cpp(SEXP lfmcmc, std::vector params_init_, size_t n_samples_, epiworld_double epsilon_); +extern "C" SEXP _epiworldR_run_lfmcmc_cpp(SEXP lfmcmc, SEXP params_init_, SEXP n_samples_, SEXP epsilon_) { + BEGIN_CPP11 + return cpp11::as_sexp(run_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(params_init_), cpp11::as_cpp>(n_samples_), cpp11::as_cpp>(epsilon_))); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1007,6 +1014,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_rm_tool_cpp", (DL_FUNC) &_epiworldR_rm_tool_cpp, 2}, {"_epiworldR_rm_virus_cpp", (DL_FUNC) &_epiworldR_rm_virus_cpp, 2}, {"_epiworldR_run_cpp", (DL_FUNC) &_epiworldR_run_cpp, 3}, + {"_epiworldR_run_lfmcmc_cpp", (DL_FUNC) &_epiworldR_run_lfmcmc_cpp, 4}, {"_epiworldR_run_multiple_cpp", (DL_FUNC) &_epiworldR_run_multiple_cpp, 8}, {"_epiworldR_set_agents_data_cpp", (DL_FUNC) &_epiworldR_set_agents_data_cpp, 3}, {"_epiworldR_set_death_reduction_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_cpp, 2}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 270e8de1..12113ff1 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -1,16 +1,93 @@ #include "cpp11.hpp" #include "cpp11/external_pointer.hpp" +#include "cpp11/r_vector.hpp" #include "epiworld-common.h" +using namespace epiworld; + +#define TData_default std::vector< int > +// #define LFMCMCSimFun_default std::function&,epiworld::LFMCMC*)> +// #define LFMCMCSummaryFun_default std::function&,const TData_default&,epiworld::LFMCMC*)> +// #define LFMCMCProposalFun_default std::function&,const std::vector< epiworld_double >&,epiworld::LFMCMC*)> +// #define LFMCMCKernelFun_default std::function&,const std::vector< epiworld_double >&,epiworld_double,epiworld::LFMCMC*)> + +#define WrapLFMCMC(a) \ + cpp11::external_pointer> (a) + // LFMCMC definitions: // https://github.com/UofUEpiBio/epiworld/tree/master/include/epiworld/math/lfmcmc [[cpp11::register]] SEXP LFMCMC_cpp() { - cpp11::external_pointer>> lfmcmc_ptr( - new epiworld::LFMCMC>() + WrapLFMCMC(lfmcmc_ptr)( + new LFMCMC() ); return lfmcmc_ptr; } + +[[cpp11::register]] +SEXP run_lfmcmc_cpp( + SEXP lfmcmc, + std::vector params_init_, + size_t n_samples_, + epiworld_double epsilon_ +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->run(params_init_, n_samples_, epsilon_); + return lfmcmc; +} + + +// [[cpp11::register]] +// SEXP set_observed_data_cpp( +// SEXP lfmcmc, +// TData_default & observed_data_ +// ) { +// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); +// lfmcmc_ptr->set_observed_data(observed_data_); +// return lfmcmc; +// } + +// [[cpp11::register]] +// SEXP set_proposal_fun_cpp( +// SEXP lfmcmc, +// LFMCMCProposalFun_default fun +// ) { +// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); +// lfmcmc_ptr->set_proposal_fun(fun); +// return lfmcmc; +// } + +// [[cpp11::register]] +// SEXP set_simulation_fun_cpp( +// SEXP lfmcmc, +// LFMCMCSimFun_default fun +// ) { +// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); +// lfmcmc_ptr->set_simulation_fun(fun); +// return lfmcmc; +// } + +// [[cpp11::register]] +// SEXP set_summary_fun_cpp( +// SEXP lfmcmc, +// LFMCMCSummaryFun_default fun +// ) { +// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); +// lfmcmc_ptr->set_summary_fun(fun); +// return lfmcmc; +// } + +// [[cpp11::register]] +// SEXP set_kernel_fun_cpp( +// SEXP lfmcmc, +// LFMCMCKernelFun_default fun +// ) { +// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); +// lfmcmc_ptr->set_kernel_fun(fun); +// return lfmcmc; +// } + +#undef WrapLFMCMC From a6ba1741fa6ff1a95af7929b60c0a4919aab4c80 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 16 Oct 2024 14:17:26 -0600 Subject: [PATCH 10/70] Add set_observed_data to LFMCMC --- NAMESPACE | 1 + R/LFMCMC.R | 16 +++++----------- R/cpp11.R | 4 ++++ src/cpp11.cpp | 8 ++++++++ src/lfmcmc.cpp | 20 ++++++++++---------- 5 files changed, 28 insertions(+), 21 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index d5ffc903..ccfbb52c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -184,6 +184,7 @@ export(set_incubation_ptr) export(set_name) export(set_name_tool) export(set_name_virus) +export(set_observed_data.epiworld_lfmcmc) export(set_param) export(set_prob_death) export(set_prob_death_fun) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index cb739557..da7c8afd 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -15,17 +15,11 @@ run.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { invisible(lfmcmc) } -# #' @export -# run.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { -# run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) -# invisible(lfmcmc) -# } - -# #' @export -# set_observed_data.epiworld_lfmcmc <- function(lfmcmc, observed_data_) { -# set_observed_data_cpp(lfmcmc, observed_data_) -# invisible(lfmcmc) -# } +#' @export +set_observed_data.epiworld_lfmcmc <- function(lfmcmc, observed_data_) { + set_observed_data_cpp(lfmcmc, observed_data_) + invisible(lfmcmc) +} # #' @export # set_proposal_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { diff --git a/R/cpp11.R b/R/cpp11.R index 6e60fcaf..468dd23a 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -228,6 +228,10 @@ run_lfmcmc_cpp <- function(lfmcmc, params_init_, n_samples_, epsilon_) { .Call(`_epiworldR_run_lfmcmc_cpp`, lfmcmc, params_init_, n_samples_, epsilon_) } +set_observed_data_cpp <- function(lfmcmc, observed_data_) { + .Call(`_epiworldR_set_observed_data_cpp`, lfmcmc, observed_data_) +} + print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 5da0d3ba..5006ce17 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -404,6 +404,13 @@ extern "C" SEXP _epiworldR_run_lfmcmc_cpp(SEXP lfmcmc, SEXP params_init_, SEXP n return cpp11::as_sexp(run_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(params_init_), cpp11::as_cpp>(n_samples_), cpp11::as_cpp>(epsilon_))); END_CPP11 } +// lfmcmc.cpp +SEXP set_observed_data_cpp(SEXP lfmcmc, std::vector< int > observed_data_); +extern "C" SEXP _epiworldR_set_observed_data_cpp(SEXP lfmcmc, SEXP observed_data_) { + BEGIN_CPP11 + return cpp11::as_sexp(set_observed_data_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(observed_data_))); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1029,6 +1036,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_set_name_cpp", (DL_FUNC) &_epiworldR_set_name_cpp, 2}, {"_epiworldR_set_name_tool_cpp", (DL_FUNC) &_epiworldR_set_name_tool_cpp, 2}, {"_epiworldR_set_name_virus_cpp", (DL_FUNC) &_epiworldR_set_name_virus_cpp, 2}, + {"_epiworldR_set_observed_data_cpp", (DL_FUNC) &_epiworldR_set_observed_data_cpp, 2}, {"_epiworldR_set_param_cpp", (DL_FUNC) &_epiworldR_set_param_cpp, 3}, {"_epiworldR_set_prob_death_cpp", (DL_FUNC) &_epiworldR_set_prob_death_cpp, 2}, {"_epiworldR_set_prob_death_fun_cpp", (DL_FUNC) &_epiworldR_set_prob_death_fun_cpp, 3}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 12113ff1..763227e3 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -39,16 +39,16 @@ SEXP run_lfmcmc_cpp( return lfmcmc; } - -// [[cpp11::register]] -// SEXP set_observed_data_cpp( -// SEXP lfmcmc, -// TData_default & observed_data_ -// ) { -// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); -// lfmcmc_ptr->set_observed_data(observed_data_); -// return lfmcmc; -// } +// observed_data_ should be of type TData +[[cpp11::register]] +SEXP set_observed_data_cpp( + SEXP lfmcmc, + std::vector< int > observed_data_ +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_observed_data(observed_data_); + return lfmcmc; +} // [[cpp11::register]] // SEXP set_proposal_fun_cpp( From 7259eab661ae4e4d4d4b31458b323c69927e74a3 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 16 Oct 2024 14:47:30 -0600 Subject: [PATCH 11/70] Add set_proposal_fun, set_simulation_fun, set_summary_fun, and set_kernel_fun --- NAMESPACE | 4 +++ R/LFMCMC.R | 40 ++++++++++++------------ R/cpp11.R | 16 ++++++++++ src/cpp11.cpp | 32 ++++++++++++++++++++ src/lfmcmc.cpp | 82 +++++++++++++++++++++++++------------------------- 5 files changed, 113 insertions(+), 61 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ccfbb52c..f44367e7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -181,6 +181,7 @@ export(set_distribution_virus) export(set_incubation) export(set_incubation_fun) export(set_incubation_ptr) +export(set_kernel_fun.epiworld_lfmcmc) export(set_name) export(set_name_tool) export(set_name_virus) @@ -195,9 +196,12 @@ export(set_prob_infecting_ptr) export(set_prob_recovery) export(set_prob_recovery_fun) export(set_prob_recovery_ptr) +export(set_proposal_fun.epiworld_lfmcmc) export(set_recovery_enhancer) export(set_recovery_enhancer_fun) export(set_recovery_enhancer_ptr) +export(set_simulation_fun.epiworld_lfmcmc) +export(set_summary_fun.epiworld_lfmcmc) export(set_susceptibility_reduction) export(set_susceptibility_reduction_fun) export(set_susceptibility_reduction_ptr) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index da7c8afd..dc6b9d03 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -21,26 +21,26 @@ set_observed_data.epiworld_lfmcmc <- function(lfmcmc, observed_data_) { invisible(lfmcmc) } -# #' @export -# set_proposal_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { -# set_proposal_fun_cpp(lfmcmc, fun) -# invisible(lfmcmc) -# } +#' @export +set_proposal_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { + set_proposal_fun_cpp(lfmcmc, fun) + invisible(lfmcmc) +} -# #' @export -# set_simulation_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { -# set_simulation_fun_cpp(lfmcmc, fun) -# invisible(lfmcmc) -# } +#' @export +set_simulation_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { + set_simulation_fun_cpp(lfmcmc, fun) + invisible(lfmcmc) +} -# #' @export -# set_summary_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { -# set_summary_fun_cpp(lfmcmc, fun) -# invisible(lfmcmc) -# } +#' @export +set_summary_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { + set_summary_fun_cpp(lfmcmc, fun) + invisible(lfmcmc) +} -# #' @export -# set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { -# set_kernel_fun_cpp(lfmcmc, fun) -# invisible(lfmcmc) -# } +#' @export +set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { + set_kernel_fun_cpp(lfmcmc, fun) + invisible(lfmcmc) +} diff --git a/R/cpp11.R b/R/cpp11.R index 468dd23a..3b873cf3 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -232,6 +232,22 @@ 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) +} + +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) +} + print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 5006ce17..f43622a3 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -411,6 +411,34 @@ extern "C" SEXP _epiworldR_set_observed_data_cpp(SEXP lfmcmc, SEXP observed_data return cpp11::as_sexp(set_observed_data_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(observed_data_))); END_CPP11 } +// lfmcmc.cpp +SEXP set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun); +extern "C" SEXP _epiworldR_set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(set_proposal_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); + END_CPP11 +} +// lfmcmc.cpp +SEXP set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun); +extern "C" SEXP _epiworldR_set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(set_simulation_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); + END_CPP11 +} +// lfmcmc.cpp +SEXP set_summary_fun_cpp(SEXP lfmcmc, SEXP fun); +extern "C" SEXP _epiworldR_set_summary_fun_cpp(SEXP lfmcmc, SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(set_summary_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); + END_CPP11 +} +// lfmcmc.cpp +SEXP set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun); +extern "C" SEXP _epiworldR_set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(set_kernel_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1033,6 +1061,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_set_incubation_cpp", (DL_FUNC) &_epiworldR_set_incubation_cpp, 2}, {"_epiworldR_set_incubation_fun_cpp", (DL_FUNC) &_epiworldR_set_incubation_fun_cpp, 3}, {"_epiworldR_set_incubation_ptr_cpp", (DL_FUNC) &_epiworldR_set_incubation_ptr_cpp, 3}, + {"_epiworldR_set_kernel_fun_cpp", (DL_FUNC) &_epiworldR_set_kernel_fun_cpp, 2}, {"_epiworldR_set_name_cpp", (DL_FUNC) &_epiworldR_set_name_cpp, 2}, {"_epiworldR_set_name_tool_cpp", (DL_FUNC) &_epiworldR_set_name_tool_cpp, 2}, {"_epiworldR_set_name_virus_cpp", (DL_FUNC) &_epiworldR_set_name_virus_cpp, 2}, @@ -1047,9 +1076,12 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_set_prob_recovery_cpp", (DL_FUNC) &_epiworldR_set_prob_recovery_cpp, 2}, {"_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_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}, + {"_epiworldR_set_simulation_fun_cpp", (DL_FUNC) &_epiworldR_set_simulation_fun_cpp, 2}, + {"_epiworldR_set_summary_fun_cpp", (DL_FUNC) &_epiworldR_set_summary_fun_cpp, 2}, {"_epiworldR_set_susceptibility_reduction_cpp", (DL_FUNC) &_epiworldR_set_susceptibility_reduction_cpp, 2}, {"_epiworldR_set_susceptibility_reduction_fun_cpp", (DL_FUNC) &_epiworldR_set_susceptibility_reduction_fun_cpp, 3}, {"_epiworldR_set_susceptibility_reduction_ptr_cpp", (DL_FUNC) &_epiworldR_set_susceptibility_reduction_ptr_cpp, 3}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 763227e3..657931d3 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -7,13 +7,9 @@ using namespace epiworld; #define TData_default std::vector< int > -// #define LFMCMCSimFun_default std::function&,epiworld::LFMCMC*)> -// #define LFMCMCSummaryFun_default std::function&,const TData_default&,epiworld::LFMCMC*)> -// #define LFMCMCProposalFun_default std::function&,const std::vector< epiworld_double >&,epiworld::LFMCMC*)> -// #define LFMCMCKernelFun_default std::function&,const std::vector< epiworld_double >&,epiworld_double,epiworld::LFMCMC*)> #define WrapLFMCMC(a) \ - cpp11::external_pointer> (a) + cpp11::external_pointer> (a) // LFMCMC definitions: // https://github.com/UofUEpiBio/epiworld/tree/master/include/epiworld/math/lfmcmc @@ -50,44 +46,48 @@ SEXP set_observed_data_cpp( return lfmcmc; } -// [[cpp11::register]] -// SEXP set_proposal_fun_cpp( -// SEXP lfmcmc, -// LFMCMCProposalFun_default fun -// ) { -// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); -// lfmcmc_ptr->set_proposal_fun(fun); -// return lfmcmc; -// } +[[cpp11::register]] +SEXP set_proposal_fun_cpp( + SEXP lfmcmc, + SEXP fun +) { + cpp11::external_pointer> fun_ptr(fun); + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_proposal_fun(*fun_ptr); + return lfmcmc; +} -// [[cpp11::register]] -// SEXP set_simulation_fun_cpp( -// SEXP lfmcmc, -// LFMCMCSimFun_default fun -// ) { -// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); -// lfmcmc_ptr->set_simulation_fun(fun); -// return lfmcmc; -// } +[[cpp11::register]] +SEXP set_simulation_fun_cpp( + SEXP lfmcmc, + SEXP fun +) { + cpp11::external_pointer> fun_ptr(fun); + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_simulation_fun(*fun_ptr); + return lfmcmc; +} -// [[cpp11::register]] -// SEXP set_summary_fun_cpp( -// SEXP lfmcmc, -// LFMCMCSummaryFun_default fun -// ) { -// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); -// lfmcmc_ptr->set_summary_fun(fun); -// return lfmcmc; -// } +[[cpp11::register]] +SEXP set_summary_fun_cpp( + SEXP lfmcmc, + SEXP fun +) { + cpp11::external_pointer> fun_ptr(fun); + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_summary_fun(*fun_ptr); + return lfmcmc; +} -// [[cpp11::register]] -// SEXP set_kernel_fun_cpp( -// SEXP lfmcmc, -// LFMCMCKernelFun_default fun -// ) { -// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); -// lfmcmc_ptr->set_kernel_fun(fun); -// return lfmcmc; -// } +[[cpp11::register]] +SEXP set_kernel_fun_cpp( + SEXP lfmcmc, + SEXP fun +) { + cpp11::external_pointer> fun_ptr(fun); + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_kernel_fun(*fun_ptr); + return lfmcmc; +} #undef WrapLFMCMC From 15c6965687690d8aa062b6996a090e6cd5958a47 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 16 Oct 2024 15:12:46 -0600 Subject: [PATCH 12/70] Document LFMCMC functions --- R/LFMCMC.R | 29 ++++++++++++++++++++++++++++- man/LFMCMC.Rd | 50 ++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 76 insertions(+), 3 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index dc6b9d03..cf0b426e 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -1,6 +1,7 @@ -#' LFMCMC +#' Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) #' #' +#' @returns The model of class `epiworld_lfmcmc` #' @export LFMCMC <- function() { structure( @@ -9,36 +10,62 @@ LFMCMC <- function() { ) } +#' @rdname LFMCMC +#' @param lfmcmc LFMCMC model +#' @param params_init_ Initial model parameters +#' @param n_samples_ Number of samples +#' @param epsilon_ Epsilon parameter +#' @returns The simulated model of class `epiworld_lfmcmc`. #' @export run.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) 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.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.epiworld_lfmcmc <- function(lfmcmc, fun) { set_proposal_fun_cpp(lfmcmc, fun) 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.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.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.epiworld_lfmcmc <- function(lfmcmc, fun) { set_kernel_fun_cpp(lfmcmc, fun) diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index c2619442..ed51d164 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -2,10 +2,56 @@ % Please edit documentation in R/LFMCMC.R \name{LFMCMC} \alias{LFMCMC} -\title{LFMCMC} +\alias{run.epiworld_lfmcmc} +\alias{set_observed_data.epiworld_lfmcmc} +\alias{set_proposal_fun.epiworld_lfmcmc} +\alias{set_simulation_fun.epiworld_lfmcmc} +\alias{set_summary_fun.epiworld_lfmcmc} +\alias{set_kernel_fun.epiworld_lfmcmc} +\title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} \usage{ LFMCMC() + +\method{run}{epiworld_lfmcmc}(lfmcmc, params_init_, n_samples_, epsilon_) + +set_observed_data.epiworld_lfmcmc(lfmcmc, observed_data_) + +set_proposal_fun.epiworld_lfmcmc(lfmcmc, fun) + +set_simulation_fun.epiworld_lfmcmc(lfmcmc, fun) + +set_summary_fun.epiworld_lfmcmc(lfmcmc, fun) + +set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) +} +\arguments{ +\item{lfmcmc}{LFMCMC model} + +\item{params_init_}{Initial model parameters} + +\item{n_samples_}{Number of samples} + +\item{epsilon_}{Epsilon parameter} + +\item{observed_data_}{Observed data} + +\item{fun}{The LFMCMC kernel function} +} +\value{ +The model of class \code{epiworld_lfmcmc} + +The simulated model of class \code{epiworld_lfmcmc}. + +The lfmcmc model with the observed data added + +The lfmcmc model with the proposal function added + +The lfmcmc model with the simulation function added + +The lfmcmc model with the summary function added + +The lfmcmc model with the kernel function added } \description{ -LFMCMC +Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) } From fe5b263119546a4bb07cc516d18928a54d71a42a Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 16 Oct 2024 15:44:12 -0600 Subject: [PATCH 13/70] Add basic example and try resolving generic run class warning --- R/LFMCMC.R | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index cf0b426e..eac59093 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -1,7 +1,13 @@ #' Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) #' #' -#' @returns The model of class `epiworld_lfmcmc` +#' @aliases epiworld_lfmcmc +#' @details +#' TODO: Detail LFMCMC +#' @returns +#' - The `LFMCMC`function returns a model of class [epiworld_lfmcmc]. +#' @examples +#' model_lfmcmc <- LFMCMC() #' @export LFMCMC <- function() { structure( @@ -11,14 +17,14 @@ LFMCMC <- function() { } #' @rdname LFMCMC -#' @param lfmcmc LFMCMC model +#' @param model LFMCMC model #' @param params_init_ Initial model parameters #' @param n_samples_ Number of samples #' @param epsilon_ Epsilon parameter #' @returns The simulated model of class `epiworld_lfmcmc`. #' @export -run.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { - run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) +run.epiworld_lfmcmc <- function(model, params_init_, n_samples_, epsilon_) { + run_lfmcmc_cpp(model, params_init_, n_samples_, epsilon_) invisible(lfmcmc) } From af3d4868fab5cc446544c8fd7be99c40c7e174d5 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 16 Oct 2024 15:45:29 -0600 Subject: [PATCH 14/70] Run roxygen2 on LFMCMC --- man/LFMCMC.Rd | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index ed51d164..6f4057fe 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/LFMCMC.R \name{LFMCMC} \alias{LFMCMC} +\alias{epiworld_lfmcmc} \alias{run.epiworld_lfmcmc} \alias{set_observed_data.epiworld_lfmcmc} \alias{set_proposal_fun.epiworld_lfmcmc} @@ -12,7 +13,7 @@ \usage{ LFMCMC() -\method{run}{epiworld_lfmcmc}(lfmcmc, params_init_, n_samples_, epsilon_) +\method{run}{epiworld_lfmcmc}(model, params_init_, n_samples_, epsilon_) set_observed_data.epiworld_lfmcmc(lfmcmc, observed_data_) @@ -25,7 +26,7 @@ set_summary_fun.epiworld_lfmcmc(lfmcmc, fun) set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) } \arguments{ -\item{lfmcmc}{LFMCMC model} +\item{model}{LFMCMC model} \item{params_init_}{Initial model parameters} @@ -33,12 +34,16 @@ set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) \item{epsilon_}{Epsilon parameter} +\item{lfmcmc}{LFMCMC model} + \item{observed_data_}{Observed data} \item{fun}{The LFMCMC kernel function} } \value{ -The model of class \code{epiworld_lfmcmc} +\itemize{ +\item The \code{LFMCMC}function returns a model of class \link{epiworld_lfmcmc}. +} The simulated model of class \code{epiworld_lfmcmc}. @@ -55,3 +60,9 @@ The lfmcmc model with the kernel function added \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) } +\details{ +TODO: Detail LFMCMC +} +\examples{ +model_lfmcmc <- LFMCMC() +} From 0ed688984ab88731b0452f11cffdec17a0903fd8 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 08:17:22 -0600 Subject: [PATCH 15/70] Rename LFMCMC run function to run_lfmcmc --- NAMESPACE | 2 +- R/LFMCMC.R | 6 +++--- man/LFMCMC.Rd | 8 +++----- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f44367e7..9e244a90 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -72,7 +72,6 @@ S3method(queuing_off,epiworld_model) S3method(queuing_on,epiworld_model) S3method(queuing_on,epiworld_seirconn) S3method(queuing_on,epiworld_sirconn) -S3method(run,epiworld_lfmcmc) S3method(run,epiworld_model) S3method(run_multiple,epiworld_model) S3method(set_name,epiworld_model) @@ -169,6 +168,7 @@ export(rm_entity) export(rm_tool) export(rm_virus) export(run) +export(run_lfmcmc.epiworld_lfmcmc) export(run_multiple) export(run_multiple_get_results) export(set_agents_data) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index eac59093..291d6867 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -17,14 +17,14 @@ LFMCMC <- function() { } #' @rdname LFMCMC -#' @param model LFMCMC model +#' @param lfmcmc LFMCMC model #' @param params_init_ Initial model parameters #' @param n_samples_ Number of samples #' @param epsilon_ Epsilon parameter #' @returns The simulated model of class `epiworld_lfmcmc`. #' @export -run.epiworld_lfmcmc <- function(model, params_init_, n_samples_, epsilon_) { - run_lfmcmc_cpp(model, params_init_, n_samples_, epsilon_) +run_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { + run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) invisible(lfmcmc) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 6f4057fe..a98ea58d 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -3,7 +3,7 @@ \name{LFMCMC} \alias{LFMCMC} \alias{epiworld_lfmcmc} -\alias{run.epiworld_lfmcmc} +\alias{run_lfmcmc.epiworld_lfmcmc} \alias{set_observed_data.epiworld_lfmcmc} \alias{set_proposal_fun.epiworld_lfmcmc} \alias{set_simulation_fun.epiworld_lfmcmc} @@ -13,7 +13,7 @@ \usage{ LFMCMC() -\method{run}{epiworld_lfmcmc}(model, params_init_, n_samples_, epsilon_) +run_lfmcmc.epiworld_lfmcmc(lfmcmc, params_init_, n_samples_, epsilon_) set_observed_data.epiworld_lfmcmc(lfmcmc, observed_data_) @@ -26,7 +26,7 @@ set_summary_fun.epiworld_lfmcmc(lfmcmc, fun) set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) } \arguments{ -\item{model}{LFMCMC model} +\item{lfmcmc}{LFMCMC model} \item{params_init_}{Initial model parameters} @@ -34,8 +34,6 @@ set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) \item{epsilon_}{Epsilon parameter} -\item{lfmcmc}{LFMCMC model} - \item{observed_data_}{Observed data} \item{fun}{The LFMCMC kernel function} From badf86346075c3f5810e28e12a995c5e1adfa631 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 09:02:11 -0600 Subject: [PATCH 16/70] Add epiworld_double macro to Makevars.win --- src/Makevars.win | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makevars.win b/src/Makevars.win index 15c6b642..31bc1854 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -2,7 +2,7 @@ PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) # This is necesary since ARMADILLO now supports OpenMP PKG_CXXFLAGS=$(SHLIB_OPENMP_CXXFLAGS) -I../inst/include/ \ - -Dprintf_epiworld=Rprintf + -Dprintf_epiworld=Rprintf -Depiworld_double=double # For testing #PKG_CXXFLAGS=-Wall From 202c48911464a999c53bef66f4efa7f62405b6c9 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 12:10:56 -0600 Subject: [PATCH 17/70] Create likelihood-free0mcmc.Rmd --- vignettes/likelihood-free-mcmc.Rmd | 111 +++++++++++++++++++++++++++++ 1 file changed, 111 insertions(+) create mode 100644 vignettes/likelihood-free-mcmc.Rmd diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd new file mode 100644 index 00000000..e0914a09 --- /dev/null +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -0,0 +1,111 @@ +--- +title: "Likelihood Free Markhov Chain Monte Carlo (LFMCMC)" +author: + - Andrew Pulsipher +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{LFMCMC} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- +```{r setup, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", out.width = "80%", fig.width = 7, fig.height = 5, + fig.align = "center" +) +``` +# Introduction +The purpose of the "lfmcmc" function is to perform a Likelihood-Free Markhov Chain Monte Carlo simulation. + +# Example: Using LFMCMC to calibrate SIR Model + +## Setup and Running Model +Create an SIR Model and add a small world population. +```{r sir-setup} +library(epiworldR) + +model_seed <- 122 + +model_sir <- ModelSIR( + name = "COVID-19", + prevalence = .1, + transmission_rate = .1, + 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 +) + +print(model_sir) +``` + +## Extract Observed data +```{r extract-obs-data} +obs_data <- get_today_total(model_sir) +``` + +## Setup and Run LFMCMC +```{r lfmcmc-setup} +# Define Simulation Function +simfun <- function(params, m) { + set_param(model_sir, "Recovery Rate", params[0]) + set_param(model_sir, "Transmission Rate", params[1]) + reset(model_sir) + run( + model_sir, + ndays = 50, + seed = model_seed + ) + res <- get_today_total(model_sir) + return(res) +} +# Define Summary Function +sumfun <- function(res, dat, m) { + # if (res.size() == 0) + # res.resize(data.size()) + + # for (i in dat.size()) + # res[i] = static_cast(dat[i]) + + # return +} +# Define Proposal Function +propfun <- function(scale, lb, ub) { + +} +# Define Kernel Function +kernfun <- function() { + +} + +par0 <- c(.5, .5) + +# lfmcmc_model <- LFMCMC() +# set_simulation_fun(lfmcmc_model, simfun) +# set_summary_fun(lfmcmc_model, sumfun) +# set_proposal_fun(lfmcmc_model, propfun) +# set_kernel_fun(lfmcmc_model, kernfun) +# set_observed_data(lfmcmc_model, obs_dat) +# run_lfmcmc(lfmcmc_model, par0,2000,1) + +# lfmcmc_model +# set_rand_engine(get_rand_endgine(model_sir)) |> +# set_par_names({"Immune recovery", "Infectiousness"}) |> +# set_stats_names(get_states(model_sir)) |> +# print() +``` From 46101798ab7428c5528a038b0d13f30164a34dc5 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 12:12:36 -0600 Subject: [PATCH 18/70] Add TODO tags to mark needed work --- vignettes/likelihood-free-mcmc.Rmd | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index e0914a09..af02ccc6 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -74,7 +74,7 @@ simfun <- function(params, m) { res <- get_today_total(model_sir) return(res) } -# Define Summary Function +# TODO: Define Summary Function sumfun <- function(res, dat, m) { # if (res.size() == 0) # res.resize(data.size()) @@ -84,17 +84,19 @@ sumfun <- function(res, dat, m) { # return } -# Define Proposal Function +# TODO: Define Proposal Function propfun <- function(scale, lb, ub) { } -# Define Kernel Function +# TODO: Define Kernel Function kernfun <- function() { } +# Set initial parameters par0 <- c(.5, .5) +# TODO: make these work # lfmcmc_model <- LFMCMC() # set_simulation_fun(lfmcmc_model, simfun) # set_summary_fun(lfmcmc_model, sumfun) @@ -104,6 +106,8 @@ par0 <- c(.5, .5) # run_lfmcmc(lfmcmc_model, par0,2000,1) # lfmcmc_model + +# TODO: Add this functionality to LFMCMC in epiworldR (currently not available methods) # set_rand_engine(get_rand_endgine(model_sir)) |> # set_par_names({"Immune recovery", "Infectiousness"}) |> # set_stats_names(get_states(model_sir)) |> From 0dfb9a2e89a49140d2d6f948fbd0f1695b4ef7df Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 13:18:54 -0600 Subject: [PATCH 19/70] Add seed, set_param_nams_, set_stats_names, print to lfmcmc --- NAMESPACE | 4 ++++ R/LFMCMC.R | 39 +++++++++++++++++++++++++++++++++++++++ R/cpp11.R | 16 ++++++++++++++++ man/LFMCMC.Rd | 26 ++++++++++++++++++++++++++ src/cpp11.cpp | 32 ++++++++++++++++++++++++++++++++ src/lfmcmc.cpp | 40 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 157 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 9e244a90..c95ab8c4 100644 --- a/NAMESPACE +++ b/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) @@ -171,6 +172,7 @@ export(run) export(run_lfmcmc.epiworld_lfmcmc) export(run_multiple) export(run_multiple_get_results) +export(seed_lfmcmc.epiworld_lfmcmc) export(set_agents_data) export(set_death_reduction) export(set_death_reduction_fun) @@ -186,6 +188,7 @@ export(set_name) export(set_name_tool) export(set_name_virus) export(set_observed_data.epiworld_lfmcmc) +export(set_par_names.epiworld_lfmcmc) export(set_param) export(set_prob_death) export(set_prob_death_fun) @@ -201,6 +204,7 @@ export(set_recovery_enhancer) export(set_recovery_enhancer_fun) export(set_recovery_enhancer_ptr) export(set_simulation_fun.epiworld_lfmcmc) +export(set_stats_names.epiworld_lfmcmc) export(set_summary_fun.epiworld_lfmcmc) export(set_susceptibility_reduction) export(set_susceptibility_reduction_fun) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 291d6867..92d0056b 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -77,3 +77,42 @@ set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { set_kernel_fun_cpp(lfmcmc, fun) invisible(lfmcmc) } + +#' @rdname LFMCMC +#' @param lfmcmc LFMCMC model +#' @param s The rand engine seed +#' @returns The lfmcmc model with the seed set +#' @export +seed_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, s) { + seed_lfmcmc_cpp(lfmcmc, s) + 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.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.epiworld_lfmcmc <- function(lfmcmc, names) { + set_stats_names_cpp(lfmcmc, names) + invisible(lfmcmc) +} + +#' @rdname LFMCMC +#' @param x LFMCMC model to print +#' @returns The lfmcmc model +#' @export +print.epiworld_lfmcmc <- function(x, ...) { + print_lfmcmc_cpp(x) + invisible(x) +} diff --git a/R/cpp11.R b/R/cpp11.R index 3b873cf3..7a934e7c 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -248,6 +248,22 @@ set_kernel_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_kernel_fun_cpp`, lfmcmc, fun) } +seed_lfmcmc_cpp <- function(lfmcmc, s) { + .Call(`_epiworldR_seed_lfmcmc_cpp`, lfmcmc, s) +} + +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) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index a98ea58d..a534f0d2 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -9,6 +9,10 @@ \alias{set_simulation_fun.epiworld_lfmcmc} \alias{set_summary_fun.epiworld_lfmcmc} \alias{set_kernel_fun.epiworld_lfmcmc} +\alias{seed_lfmcmc.epiworld_lfmcmc} +\alias{set_par_names.epiworld_lfmcmc} +\alias{set_stats_names.epiworld_lfmcmc} +\alias{print.epiworld_lfmcmc} \title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} \usage{ LFMCMC() @@ -24,6 +28,14 @@ set_simulation_fun.epiworld_lfmcmc(lfmcmc, fun) set_summary_fun.epiworld_lfmcmc(lfmcmc, fun) set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) + +seed_lfmcmc.epiworld_lfmcmc(lfmcmc, s) + +set_par_names.epiworld_lfmcmc(lfmcmc, names) + +set_stats_names.epiworld_lfmcmc(lfmcmc, names) + +\method{print}{epiworld_lfmcmc}(x, ...) } \arguments{ \item{lfmcmc}{LFMCMC model} @@ -37,6 +49,12 @@ set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) \item{observed_data_}{Observed data} \item{fun}{The LFMCMC kernel function} + +\item{s}{The rand engine seed} + +\item{names}{The model stats names} + +\item{x}{LFMCMC model to print} } \value{ \itemize{ @@ -54,6 +72,14 @@ The lfmcmc model with the simulation function added The lfmcmc model with the summary function added The lfmcmc model with the kernel function added + +The lfmcmc model with the seed set + +The lfmcmc model with the parameter names added + +The lfmcmc model with the stats names added + +The lfmcmc model } \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) diff --git a/src/cpp11.cpp b/src/cpp11.cpp index f43622a3..de604c3c 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -439,6 +439,34 @@ extern "C" SEXP _epiworldR_set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun) { return cpp11::as_sexp(set_kernel_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); 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 + return cpp11::as_sexp(seed_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(s))); + END_CPP11 +} +// lfmcmc.cpp +SEXP set_par_names_cpp(SEXP lfmcmc, std::vector< std::string > names); +extern "C" SEXP _epiworldR_set_par_names_cpp(SEXP lfmcmc, SEXP names) { + BEGIN_CPP11 + return cpp11::as_sexp(set_par_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); +extern "C" SEXP _epiworldR_print_lfmcmc_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(print_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1040,6 +1068,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_print_cpp", (DL_FUNC) &_epiworldR_print_cpp, 2}, {"_epiworldR_print_entity_cpp", (DL_FUNC) &_epiworldR_print_entity_cpp, 1}, {"_epiworldR_print_global_action_cpp", (DL_FUNC) &_epiworldR_print_global_action_cpp, 1}, + {"_epiworldR_print_lfmcmc_cpp", (DL_FUNC) &_epiworldR_print_lfmcmc_cpp, 1}, {"_epiworldR_print_tool_cpp", (DL_FUNC) &_epiworldR_print_tool_cpp, 1}, {"_epiworldR_print_virus_cpp", (DL_FUNC) &_epiworldR_print_virus_cpp, 1}, {"_epiworldR_queuing_off_cpp", (DL_FUNC) &_epiworldR_queuing_off_cpp, 1}, @@ -1051,6 +1080,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_run_cpp", (DL_FUNC) &_epiworldR_run_cpp, 3}, {"_epiworldR_run_lfmcmc_cpp", (DL_FUNC) &_epiworldR_run_lfmcmc_cpp, 4}, {"_epiworldR_run_multiple_cpp", (DL_FUNC) &_epiworldR_run_multiple_cpp, 8}, + {"_epiworldR_seed_lfmcmc_cpp", (DL_FUNC) &_epiworldR_seed_lfmcmc_cpp, 2}, {"_epiworldR_set_agents_data_cpp", (DL_FUNC) &_epiworldR_set_agents_data_cpp, 3}, {"_epiworldR_set_death_reduction_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_cpp, 2}, {"_epiworldR_set_death_reduction_fun_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_fun_cpp, 3}, @@ -1066,6 +1096,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_set_name_tool_cpp", (DL_FUNC) &_epiworldR_set_name_tool_cpp, 2}, {"_epiworldR_set_name_virus_cpp", (DL_FUNC) &_epiworldR_set_name_virus_cpp, 2}, {"_epiworldR_set_observed_data_cpp", (DL_FUNC) &_epiworldR_set_observed_data_cpp, 2}, + {"_epiworldR_set_par_names_cpp", (DL_FUNC) &_epiworldR_set_par_names_cpp, 2}, {"_epiworldR_set_param_cpp", (DL_FUNC) &_epiworldR_set_param_cpp, 3}, {"_epiworldR_set_prob_death_cpp", (DL_FUNC) &_epiworldR_set_prob_death_cpp, 2}, {"_epiworldR_set_prob_death_fun_cpp", (DL_FUNC) &_epiworldR_set_prob_death_fun_cpp, 3}, @@ -1081,6 +1112,7 @@ static const R_CallMethodDef CallEntries[] = { {"_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}, {"_epiworldR_set_simulation_fun_cpp", (DL_FUNC) &_epiworldR_set_simulation_fun_cpp, 2}, + {"_epiworldR_set_stats_names_cpp", (DL_FUNC) &_epiworldR_set_stats_names_cpp, 2}, {"_epiworldR_set_summary_fun_cpp", (DL_FUNC) &_epiworldR_set_summary_fun_cpp, 2}, {"_epiworldR_set_susceptibility_reduction_cpp", (DL_FUNC) &_epiworldR_set_susceptibility_reduction_cpp, 2}, {"_epiworldR_set_susceptibility_reduction_fun_cpp", (DL_FUNC) &_epiworldR_set_susceptibility_reduction_fun_cpp, 3}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 657931d3..27d244a8 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -90,4 +90,44 @@ SEXP set_kernel_fun_cpp( return lfmcmc; } +// s should be of type epiworld_fast_uint +[[cpp11::register]] +SEXP seed_lfmcmc_cpp( + SEXP lfmcmc, + unsigned long long int s +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->seed(s); + return lfmcmc; +} + +[[cpp11::register]] +SEXP set_par_names_cpp( + SEXP lfmcmc, + std::vector< std::string > names +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_par_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 +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->print(); + return lfmcmc; +} + #undef WrapLFMCMC From 91e031d86b9c689848e719acd830679a09f5a010 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 13:41:30 -0600 Subject: [PATCH 20/70] Update documentation on LFMCMC --- R/LFMCMC.R | 2 -- man/LFMCMC.Rd | 4 ---- vignettes/likelihood-free-mcmc.Rmd | 3 +-- 3 files changed, 1 insertion(+), 8 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 92d0056b..70ec0082 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -109,8 +109,6 @@ set_stats_names.epiworld_lfmcmc <- function(lfmcmc, names) { } #' @rdname LFMCMC -#' @param x LFMCMC model to print -#' @returns The lfmcmc model #' @export print.epiworld_lfmcmc <- function(x, ...) { print_lfmcmc_cpp(x) diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index a534f0d2..0b522951 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -53,8 +53,6 @@ set_stats_names.epiworld_lfmcmc(lfmcmc, names) \item{s}{The rand engine seed} \item{names}{The model stats names} - -\item{x}{LFMCMC model to print} } \value{ \itemize{ @@ -78,8 +76,6 @@ The lfmcmc model with the seed set The lfmcmc model with the parameter names added The lfmcmc model with the stats names added - -The lfmcmc model } \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index af02ccc6..d6506b45 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -107,8 +107,7 @@ par0 <- c(.5, .5) # lfmcmc_model -# TODO: Add this functionality to LFMCMC in epiworldR (currently not available methods) -# set_rand_engine(get_rand_endgine(model_sir)) |> +# seed(lfmcmc_model, model_seed) |> # set_par_names({"Immune recovery", "Infectiousness"}) |> # set_stats_names(get_states(model_sir)) |> # print() From ea35a86e67e15194ca67eed7b80a0905d60b4e69 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 13:47:00 -0600 Subject: [PATCH 21/70] Document params for print.epiworld_lfmcmc --- R/LFMCMC.R | 3 +++ man/LFMCMC.Rd | 6 ++++++ 2 files changed, 9 insertions(+) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 70ec0082..ebd7b37a 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -109,6 +109,9 @@ set_stats_names.epiworld_lfmcmc <- function(lfmcmc, names) { } #' @rdname LFMCMC +#' @param x LFMCMC model to print +#' @param ... Ignored +#' @returns The lfmcmc model #' @export print.epiworld_lfmcmc <- function(x, ...) { print_lfmcmc_cpp(x) diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 0b522951..c7466cbf 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -53,6 +53,10 @@ set_stats_names.epiworld_lfmcmc(lfmcmc, names) \item{s}{The rand engine seed} \item{names}{The model stats names} + +\item{x}{LFMCMC model to print} + +\item{...}{Ignored} } \value{ \itemize{ @@ -76,6 +80,8 @@ The lfmcmc model with the seed set The lfmcmc model with the parameter names added The lfmcmc model with the stats names added + +The lfmcmc model } \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) From b4c2c6a4858c259108bdb72c02f69dfc91feeb54 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 13:52:41 -0600 Subject: [PATCH 22/70] Setup function ordering for likelihood-free-mcmc.Rmd --- vignettes/likelihood-free-mcmc.Rmd | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index d6506b45..0ebab5c5 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -97,18 +97,18 @@ kernfun <- function() { par0 <- c(.5, .5) # TODO: make these work -# lfmcmc_model <- LFMCMC() -# set_simulation_fun(lfmcmc_model, simfun) -# set_summary_fun(lfmcmc_model, sumfun) -# set_proposal_fun(lfmcmc_model, propfun) -# set_kernel_fun(lfmcmc_model, kernfun) -# set_observed_data(lfmcmc_model, obs_dat) -# run_lfmcmc(lfmcmc_model, par0,2000,1) - -# lfmcmc_model - -# seed(lfmcmc_model, model_seed) |> -# set_par_names({"Immune recovery", "Infectiousness"}) |> -# set_stats_names(get_states(model_sir)) |> -# print() +lfmcmc_model <- LFMCMC() |> + 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) + +lfmcmc_model + +lfmcmc_model <- seed(lfmcmc_model, model_seed) |> + set_par_names(c("Immune recovery", "Infectiousness")) |> + set_stats_names(get_states(model_sir)) |> + print() ``` From c51281260f2909dcfbab2650269a330f82990586 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 13:58:26 -0600 Subject: [PATCH 23/70] Make lfmcmc vignette simpler to start --- vignettes/likelihood-free-mcmc.Rmd | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 0ebab5c5..1a813331 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -97,18 +97,18 @@ kernfun <- function() { par0 <- c(.5, .5) # TODO: make these work -lfmcmc_model <- LFMCMC() |> - 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) - -lfmcmc_model - -lfmcmc_model <- seed(lfmcmc_model, model_seed) |> - set_par_names(c("Immune recovery", "Infectiousness")) |> - set_stats_names(get_states(model_sir)) |> - print() +lfmcmc_model <- LFMCMC() +# 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) + +# lfmcmc_model + +# lfmcmc_model <- seed(lfmcmc_model, model_seed) |> +# set_par_names(c("Immune recovery", "Infectiousness")) |> +# set_stats_names(get_states(model_sir)) |> +# print() ``` From 4c26e7b2cb1709eef625798bd08aac2ac63b0842 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 14:03:27 -0600 Subject: [PATCH 24/70] Add set_simulation_fun in lfmcmc vignette --- vignettes/likelihood-free-mcmc.Rmd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 1a813331..761c8d5b 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -97,8 +97,8 @@ kernfun <- function() { par0 <- c(.5, .5) # TODO: make these work -lfmcmc_model <- LFMCMC() -# set_simulation_fun(simfun) |> +lfmcmc_model <- LFMCMC() |> + set_simulation_fun(simfun) # set_summary_fun(sumfun) |> # set_proposal_fun(propfun) |> # set_kernel_fun(kernfun) |> From 20e83c6f2c90d8e2098c25227035cf66b378a916 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 17 Oct 2024 14:07:28 -0600 Subject: [PATCH 25/70] Try vignette without piping --- vignettes/likelihood-free-mcmc.Rmd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 761c8d5b..71fabbf8 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -97,8 +97,8 @@ kernfun <- function() { par0 <- c(.5, .5) # TODO: make these work -lfmcmc_model <- LFMCMC() |> - set_simulation_fun(simfun) +lfmcmc_model <- LFMCMC() +set_simulation_fun(lfmcmc_model, simfun) # set_summary_fun(sumfun) |> # set_proposal_fun(propfun) |> # set_kernel_fun(kernfun) |> From 44c72c7653645ae7ee6996176cbb3827bb4d3099 Mon Sep 17 00:00:00 2001 From: Andrew Date: Mon, 21 Oct 2024 09:49:45 -0600 Subject: [PATCH 26/70] Add UseMethod export for base version of LFMCMC class methods --- NAMESPACE | 27 ++++++++++++++++++--------- R/LFMCMC.R | 27 +++++++++++++++++++++++++++ man/LFMCMC.Rd | 36 ++++++++++++++++++------------------ 3 files changed, 63 insertions(+), 27 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c95ab8c4..1a5b79cd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -74,9 +74,18 @@ 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(seed_lfmcmc,epiworld_lfmcmc) +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) @@ -169,10 +178,10 @@ export(rm_entity) export(rm_tool) export(rm_virus) export(run) -export(run_lfmcmc.epiworld_lfmcmc) +export(run_lfmcmc) export(run_multiple) export(run_multiple_get_results) -export(seed_lfmcmc.epiworld_lfmcmc) +export(seed_lfmcmc) export(set_agents_data) export(set_death_reduction) export(set_death_reduction_fun) @@ -183,12 +192,12 @@ export(set_distribution_virus) export(set_incubation) export(set_incubation_fun) export(set_incubation_ptr) -export(set_kernel_fun.epiworld_lfmcmc) +export(set_kernel_fun) export(set_name) export(set_name_tool) export(set_name_virus) -export(set_observed_data.epiworld_lfmcmc) -export(set_par_names.epiworld_lfmcmc) +export(set_observed_data) +export(set_par_names) export(set_param) export(set_prob_death) export(set_prob_death_fun) @@ -199,13 +208,13 @@ export(set_prob_infecting_ptr) export(set_prob_recovery) export(set_prob_recovery_fun) export(set_prob_recovery_ptr) -export(set_proposal_fun.epiworld_lfmcmc) +export(set_proposal_fun) export(set_recovery_enhancer) export(set_recovery_enhancer_fun) export(set_recovery_enhancer_ptr) -export(set_simulation_fun.epiworld_lfmcmc) -export(set_stats_names.epiworld_lfmcmc) -export(set_summary_fun.epiworld_lfmcmc) +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) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index ebd7b37a..4b31de96 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -22,6 +22,9 @@ LFMCMC <- function() { #' @param n_samples_ Number of samples #' @param epsilon_ Epsilon parameter #' @returns The simulated model of class `epiworld_lfmcmc`. +#' @export +run_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) UseMethod("run_lfmcmc") + #' @export run_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_) { run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) @@ -32,6 +35,9 @@ run_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon #' @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_) @@ -42,6 +48,9 @@ set_observed_data.epiworld_lfmcmc <- function(lfmcmc, observed_data_) { #' @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) @@ -52,6 +61,9 @@ set_proposal_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { #' @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) @@ -62,6 +74,9 @@ set_simulation_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { #' @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) @@ -72,6 +87,9 @@ set_summary_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { #' @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) @@ -82,6 +100,9 @@ set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { #' @param lfmcmc LFMCMC model #' @param s The rand engine seed #' @returns The lfmcmc model with the seed set +#' @export +seed_lfmcmc <- function(lfmcmc, s) UseMethod("seed_lfmcmc") + #' @export seed_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, s) { seed_lfmcmc_cpp(lfmcmc, s) @@ -92,6 +113,9 @@ seed_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, s) { #' @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) @@ -102,6 +126,9 @@ set_par_names.epiworld_lfmcmc <- function(lfmcmc, names) { #' @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) diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index c7466cbf..32f63a34 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -3,37 +3,37 @@ \name{LFMCMC} \alias{LFMCMC} \alias{epiworld_lfmcmc} -\alias{run_lfmcmc.epiworld_lfmcmc} -\alias{set_observed_data.epiworld_lfmcmc} -\alias{set_proposal_fun.epiworld_lfmcmc} -\alias{set_simulation_fun.epiworld_lfmcmc} -\alias{set_summary_fun.epiworld_lfmcmc} -\alias{set_kernel_fun.epiworld_lfmcmc} -\alias{seed_lfmcmc.epiworld_lfmcmc} -\alias{set_par_names.epiworld_lfmcmc} -\alias{set_stats_names.epiworld_lfmcmc} +\alias{run_lfmcmc} +\alias{set_observed_data} +\alias{set_proposal_fun} +\alias{set_simulation_fun} +\alias{set_summary_fun} +\alias{set_kernel_fun} +\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() -run_lfmcmc.epiworld_lfmcmc(lfmcmc, params_init_, n_samples_, epsilon_) +run_lfmcmc(lfmcmc, params_init_, n_samples_, epsilon_) -set_observed_data.epiworld_lfmcmc(lfmcmc, observed_data_) +set_observed_data(lfmcmc, observed_data_) -set_proposal_fun.epiworld_lfmcmc(lfmcmc, fun) +set_proposal_fun(lfmcmc, fun) -set_simulation_fun.epiworld_lfmcmc(lfmcmc, fun) +set_simulation_fun(lfmcmc, fun) -set_summary_fun.epiworld_lfmcmc(lfmcmc, fun) +set_summary_fun(lfmcmc, fun) -set_kernel_fun.epiworld_lfmcmc(lfmcmc, fun) +set_kernel_fun(lfmcmc, fun) -seed_lfmcmc.epiworld_lfmcmc(lfmcmc, s) +seed_lfmcmc(lfmcmc, s) -set_par_names.epiworld_lfmcmc(lfmcmc, names) +set_par_names(lfmcmc, names) -set_stats_names.epiworld_lfmcmc(lfmcmc, names) +set_stats_names(lfmcmc, names) \method{print}{epiworld_lfmcmc}(x, ...) } From 6d5902695a960f89c37bf709f80acf404bc09032 Mon Sep 17 00:00:00 2001 From: Andrew Date: Mon, 21 Oct 2024 10:34:14 -0600 Subject: [PATCH 27/70] Clean up vignette to separate failing block --- vignettes/likelihood-free-mcmc.Rmd | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 71fabbf8..a8d5daad 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -59,7 +59,7 @@ print(model_sir) obs_data <- get_today_total(model_sir) ``` -## Setup and Run LFMCMC +## Setup LFMCMC ```{r lfmcmc-setup} # Define Simulation Function simfun <- function(params, m) { @@ -95,10 +95,14 @@ kernfun <- function() { # Set initial parameters par0 <- c(.5, .5) +``` +## Run LFMCMC +```{r lfmcmc-run} # TODO: make these work -lfmcmc_model <- LFMCMC() -set_simulation_fun(lfmcmc_model, simfun) +lfmcmc_model <- LFMCMC() |> + set_simulation_fun(simfun) +# set_simulation_fun(lfmcmc_model, simfun) # set_summary_fun(sumfun) |> # set_proposal_fun(propfun) |> # set_kernel_fun(kernfun) |> From 19fb18774a004989c0019494423e6c9e308a2105 Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 22 Oct 2024 11:46:37 -0600 Subject: [PATCH 28/70] Add create_LFMCMCMSimFun_cpp() --- R/cpp11.R | 4 ++++ src/cpp11.cpp | 8 ++++++++ src/lfmcmc.cpp | 17 +++++++++++++++++ 3 files changed, 29 insertions(+) diff --git a/R/cpp11.R b/R/cpp11.R index 7a934e7c..5a00cd06 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -236,6 +236,10 @@ set_proposal_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_proposal_fun_cpp`, lfmcmc, fun) } +create_LFMCMCSimFun_cpp <- function(fun) { + .Call(`_epiworldR_create_LFMCMCSimFun_cpp`, fun) +} + set_simulation_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_simulation_fun_cpp`, lfmcmc, fun) } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index de604c3c..2a544207 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -419,6 +419,13 @@ extern "C" SEXP _epiworldR_set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun) { END_CPP11 } // lfmcmc.cpp +SEXP create_LFMCMCSimFun_cpp(cpp11::function fun); +extern "C" SEXP _epiworldR_create_LFMCMCSimFun_cpp(SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(create_LFMCMCSimFun_cpp(cpp11::as_cpp>(fun))); + END_CPP11 +} +// lfmcmc.cpp SEXP set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun); extern "C" SEXP _epiworldR_set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 @@ -1014,6 +1021,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_agents_smallworld_cpp", (DL_FUNC) &_epiworldR_agents_smallworld_cpp, 5}, {"_epiworldR_change_state_cpp", (DL_FUNC) &_epiworldR_change_state_cpp, 4}, {"_epiworldR_clone_model_cpp", (DL_FUNC) &_epiworldR_clone_model_cpp, 1}, + {"_epiworldR_create_LFMCMCSimFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCSimFun_cpp, 1}, {"_epiworldR_distribute_entity_randomly_cpp", (DL_FUNC) &_epiworldR_distribute_entity_randomly_cpp, 3}, {"_epiworldR_distribute_entity_to_set_cpp", (DL_FUNC) &_epiworldR_distribute_entity_to_set_cpp, 1}, {"_epiworldR_distribute_tool_randomly_cpp", (DL_FUNC) &_epiworldR_distribute_tool_randomly_cpp, 2}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 27d244a8..0cb433a3 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -57,6 +57,23 @@ SEXP set_proposal_fun_cpp( return lfmcmc; } +[[cpp11::register]] +SEXP create_LFMCMCSimFun_cpp( + cpp11::function fun + ) { + + LFMCMCSimFun fun_call = [fun](std::vector& params, LFMCMC* model) { + WrapLFMCMC(lfmcmc_ptr)(model); + SEXP res = fun(params, lfmcmc_ptr); + cpp11::external_pointer res_vec(res); + return *res_vec; + }; + + return cpp11::external_pointer>( + new LFMCMCSimFun(fun_call) + ); +} + [[cpp11::register]] SEXP set_simulation_fun_cpp( SEXP lfmcmc, From cb76f1e2c70fe339792a4452796a5c75f574c31d Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 22 Oct 2024 12:07:44 -0600 Subject: [PATCH 29/70] Add lambda return type --- src/lfmcmc.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 0cb433a3..ca4f0eba 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -62,7 +62,7 @@ SEXP create_LFMCMCSimFun_cpp( cpp11::function fun ) { - LFMCMCSimFun fun_call = [fun](std::vector& params, LFMCMC* model) { + LFMCMCSimFun fun_call = [fun](std::vector& params, LFMCMC* model) -> TData_default { WrapLFMCMC(lfmcmc_ptr)(model); SEXP res = fun(params, lfmcmc_ptr); cpp11::external_pointer res_vec(res); From f02d864ae6253436dafea78af5079833e0cb0d3b Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 22 Oct 2024 12:18:12 -0600 Subject: [PATCH 30/70] Fix lambda param mismatch with LFMCMCMSimFun and set correctly in se_simulation_fun_cpp --- src/lfmcmc.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index ca4f0eba..be9c1c0d 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -62,7 +62,7 @@ SEXP create_LFMCMCSimFun_cpp( cpp11::function fun ) { - LFMCMCSimFun fun_call = [fun](std::vector& params, LFMCMC* model) -> TData_default { + LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { WrapLFMCMC(lfmcmc_ptr)(model); SEXP res = fun(params, lfmcmc_ptr); cpp11::external_pointer res_vec(res); @@ -79,7 +79,7 @@ SEXP set_simulation_fun_cpp( SEXP lfmcmc, SEXP fun ) { - cpp11::external_pointer> fun_ptr(fun); + cpp11::external_pointer> fun_ptr = create_LFMCMCSimFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); lfmcmc_ptr->set_simulation_fun(*fun_ptr); return lfmcmc; From 7cf728186d1b615260a3e9b60c6dc0aaedf4a580 Mon Sep 17 00:00:00 2001 From: Andrew Date: Tue, 22 Oct 2024 15:39:12 -0600 Subject: [PATCH 31/70] Add factory methods for summary, proposal, kernel functions --- R/cpp11.R | 12 ++++++ src/cpp11.cpp | 24 +++++++++++ src/lfmcmc.cpp | 64 +++++++++++++++++++++++++++--- vignettes/likelihood-free-mcmc.Rmd | 19 +++++---- 4 files changed, 103 insertions(+), 16 deletions(-) diff --git a/R/cpp11.R b/R/cpp11.R index 5a00cd06..1106bbfd 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -232,6 +232,10 @@ set_observed_data_cpp <- function(lfmcmc, observed_data_) { .Call(`_epiworldR_set_observed_data_cpp`, lfmcmc, observed_data_) } +create_LFMCMCProposalFun_cpp <- function(fun) { + .Call(`_epiworldR_create_LFMCMCProposalFun_cpp`, fun) +} + set_proposal_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_proposal_fun_cpp`, lfmcmc, fun) } @@ -244,10 +248,18 @@ set_simulation_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_simulation_fun_cpp`, lfmcmc, fun) } +create_LFMCMCSummaryFun_cpp <- function(fun) { + .Call(`_epiworldR_create_LFMCMCSummaryFun_cpp`, fun) +} + set_summary_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_summary_fun_cpp`, lfmcmc, fun) } +create_LFMCMCKernelFun_cpp <- function(fun) { + .Call(`_epiworldR_create_LFMCMCKernelFun_cpp`, fun) +} + set_kernel_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_kernel_fun_cpp`, lfmcmc, fun) } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 2a544207..39237a59 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -412,6 +412,13 @@ extern "C" SEXP _epiworldR_set_observed_data_cpp(SEXP lfmcmc, SEXP observed_data END_CPP11 } // lfmcmc.cpp +SEXP create_LFMCMCProposalFun_cpp(cpp11::function fun); +extern "C" SEXP _epiworldR_create_LFMCMCProposalFun_cpp(SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(create_LFMCMCProposalFun_cpp(cpp11::as_cpp>(fun))); + END_CPP11 +} +// lfmcmc.cpp SEXP set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun); extern "C" SEXP _epiworldR_set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 @@ -433,6 +440,13 @@ extern "C" SEXP _epiworldR_set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun) { END_CPP11 } // lfmcmc.cpp +SEXP create_LFMCMCSummaryFun_cpp(cpp11::function fun); +extern "C" SEXP _epiworldR_create_LFMCMCSummaryFun_cpp(SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(create_LFMCMCSummaryFun_cpp(cpp11::as_cpp>(fun))); + END_CPP11 +} +// lfmcmc.cpp SEXP set_summary_fun_cpp(SEXP lfmcmc, SEXP fun); extern "C" SEXP _epiworldR_set_summary_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 @@ -440,6 +454,13 @@ extern "C" SEXP _epiworldR_set_summary_fun_cpp(SEXP lfmcmc, SEXP fun) { END_CPP11 } // lfmcmc.cpp +SEXP create_LFMCMCKernelFun_cpp(cpp11::function fun); +extern "C" SEXP _epiworldR_create_LFMCMCKernelFun_cpp(SEXP fun) { + BEGIN_CPP11 + return cpp11::as_sexp(create_LFMCMCKernelFun_cpp(cpp11::as_cpp>(fun))); + END_CPP11 +} +// lfmcmc.cpp SEXP set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun); extern "C" SEXP _epiworldR_set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 @@ -1021,7 +1042,10 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_agents_smallworld_cpp", (DL_FUNC) &_epiworldR_agents_smallworld_cpp, 5}, {"_epiworldR_change_state_cpp", (DL_FUNC) &_epiworldR_change_state_cpp, 4}, {"_epiworldR_clone_model_cpp", (DL_FUNC) &_epiworldR_clone_model_cpp, 1}, + {"_epiworldR_create_LFMCMCKernelFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCKernelFun_cpp, 1}, + {"_epiworldR_create_LFMCMCProposalFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCProposalFun_cpp, 1}, {"_epiworldR_create_LFMCMCSimFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCSimFun_cpp, 1}, + {"_epiworldR_create_LFMCMCSummaryFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCSummaryFun_cpp, 1}, {"_epiworldR_distribute_entity_randomly_cpp", (DL_FUNC) &_epiworldR_distribute_entity_randomly_cpp, 3}, {"_epiworldR_distribute_entity_to_set_cpp", (DL_FUNC) &_epiworldR_distribute_entity_to_set_cpp, 1}, {"_epiworldR_distribute_tool_randomly_cpp", (DL_FUNC) &_epiworldR_distribute_tool_randomly_cpp, 2}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index be9c1c0d..8866ccc4 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -46,17 +46,35 @@ SEXP set_observed_data_cpp( return lfmcmc; } +// LFMCMC Proposal Function +[[cpp11::register]] +SEXP create_LFMCMCProposalFun_cpp( + cpp11::function fun + ) { + + LFMCMCProposalFun fun_call = [fun](std::vector< epiworld_double >& params_now,const std::vector< epiworld_double >& params_prev, LFMCMC* model) -> void { + WrapLFMCMC(lfmcmc_ptr)(model); + fun(params_now, params_prev, lfmcmc_ptr); + return; + }; + + return cpp11::external_pointer>( + new LFMCMCProposalFun(fun_call) + ); +} + [[cpp11::register]] SEXP set_proposal_fun_cpp( SEXP lfmcmc, SEXP fun ) { - cpp11::external_pointer> fun_ptr(fun); + cpp11::external_pointer> fun_ptr = create_LFMCMCProposalFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); lfmcmc_ptr->set_proposal_fun(*fun_ptr); return lfmcmc; } +// LFMCMC Simulation Function [[cpp11::register]] SEXP create_LFMCMCSimFun_cpp( cpp11::function fun @@ -64,9 +82,8 @@ SEXP create_LFMCMCSimFun_cpp( LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { WrapLFMCMC(lfmcmc_ptr)(model); - SEXP res = fun(params, lfmcmc_ptr); - cpp11::external_pointer res_vec(res); - return *res_vec; + cpp11::external_pointer res(fun(params, lfmcmc_ptr)); + return *res; }; return cpp11::external_pointer>( @@ -85,23 +102,58 @@ SEXP set_simulation_fun_cpp( return lfmcmc; } +// LFMCMC Summary Function +[[cpp11::register]] +SEXP create_LFMCMCSummaryFun_cpp( + cpp11::function fun + ) { + + LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { + WrapLFMCMC(lfmcmc_ptr)(model); + fun(res, dat, lfmcmc_ptr); + return; + }; + + return cpp11::external_pointer>( + new LFMCMCSummaryFun(fun_call) + ); +} + [[cpp11::register]] SEXP set_summary_fun_cpp( SEXP lfmcmc, SEXP fun ) { - cpp11::external_pointer> fun_ptr(fun); + cpp11::external_pointer> fun_ptr = create_LFMCMCSummaryFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); lfmcmc_ptr->set_summary_fun(*fun_ptr); return lfmcmc; } +// LFMCMC Kernel Function +// TODO: clean up these really long lines +[[cpp11::register]] +SEXP create_LFMCMCKernelFun_cpp( + cpp11::function fun + ) { + + LFMCMCKernelFun fun_call = [fun](const std::vector< epiworld_double >& stats_now, const std::vector< epiworld_double >& stats_obs, epiworld_double epsilon, LFMCMC* model) -> epiworld_double { + WrapLFMCMC(lfmcmc_ptr)(model); + cpp11::external_pointer res(fun(stats_now, stats_obs, epsilon, lfmcmc_ptr)); + return *res; + }; + + return cpp11::external_pointer>( + new LFMCMCKernelFun(fun_call) + ); +} + [[cpp11::register]] SEXP set_kernel_fun_cpp( SEXP lfmcmc, SEXP fun ) { - cpp11::external_pointer> fun_ptr(fun); + cpp11::external_pointer> fun_ptr = create_LFMCMCKernelFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); lfmcmc_ptr->set_kernel_fun(*fun_ptr); return lfmcmc; diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index a8d5daad..9acba8bc 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -76,21 +76,21 @@ simfun <- function(params, m) { } # TODO: Define Summary Function sumfun <- function(res, dat, m) { - # if (res.size() == 0) + # if (length(res) == 0) # res.resize(data.size()) # for (i in dat.size()) # res[i] = static_cast(dat[i]) - # return + return } # TODO: Define Proposal Function -propfun <- function(scale, lb, ub) { - +propfun <- function(params_now, params_prev, m) { + return } # TODO: Define Kernel Function kernfun <- function() { - + return(1.0) } # Set initial parameters @@ -101,11 +101,10 @@ par0 <- c(.5, .5) ```{r lfmcmc-run} # TODO: make these work lfmcmc_model <- LFMCMC() |> - set_simulation_fun(simfun) -# set_simulation_fun(lfmcmc_model, simfun) -# set_summary_fun(sumfun) |> -# set_proposal_fun(propfun) |> -# set_kernel_fun(kernfun) |> + 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) From f48be565e83119480b4aa664edc944b662f8243d Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 23 Oct 2024 10:16:58 -0600 Subject: [PATCH 32/70] Add set_rand_engine function and update constructor to extract rand_engine from model --- NAMESPACE | 2 ++ R/LFMCMC.R | 21 +++++++++++++++++++-- R/cpp11.R | 8 ++++++-- man/LFMCMC.Rd | 10 +++++++++- src/cpp11.cpp | 16 ++++++++++++---- src/lfmcmc.cpp | 19 +++++++++++++++++-- vignettes/likelihood-free-mcmc.Rmd | 13 ++++++------- 7 files changed, 71 insertions(+), 18 deletions(-) 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() ``` From eb3da6c67f5f2cc8a0f789ca702bf35f62768771 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 23 Oct 2024 10:25:15 -0600 Subject: [PATCH 33/70] Document param in updated LFMCMC constructor --- R/LFMCMC.R | 2 +- man/LFMCMC.Rd | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index bba116f1..e5880aea 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -4,7 +4,7 @@ #' @aliases epiworld_lfmcmc #' @details #' TODO: Detail LFMCMC -#' TODO: Add params +#' @param model A model of class [epiworld_model] #' @returns #' - The `LFMCMC`function returns a model of class [epiworld_lfmcmc]. #' @examples diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index f15c0f50..2b95b291 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -41,6 +41,8 @@ set_stats_names(lfmcmc, names) \method{print}{epiworld_lfmcmc}(x, ...) } \arguments{ +\item{model}{A model of class \link{epiworld_model}} + \item{lfmcmc}{LFMCMC model} \item{params_init_}{Initial model parameters} @@ -95,7 +97,6 @@ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) } \details{ TODO: Detail LFMCMC -TODO: Add params } \examples{ model_lfmcmc <- LFMCMC() From 3475207c865b0ac1cfeca0992afdc84cf26dab3e Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 23 Oct 2024 10:31:38 -0600 Subject: [PATCH 34/70] Update LFMCMC example in .R file --- R/LFMCMC.R | 4 +++- man/LFMCMC.Rd | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index e5880aea..1bee4411 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -8,7 +8,9 @@ #' @returns #' - The `LFMCMC`function returns a model of class [epiworld_lfmcmc]. #' @examples -#' model_lfmcmc <- LFMCMC() +#' model_sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, +#' transmission_rate = 0.9, recovery_rate = 0.1) +#' model_lfmcmc <- LFMCMC(model_sir) #' @export LFMCMC <- function(model) { if (!inherits(model, "epiworld_model")) diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 2b95b291..c908db67 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -99,5 +99,7 @@ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) TODO: Detail LFMCMC } \examples{ -model_lfmcmc <- LFMCMC() +model_sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, + transmission_rate = 0.9, recovery_rate = 0.1) +model_lfmcmc <- LFMCMC(model_sir) } From bff88cd7c991b7ede2fab52083b01be4c7fca084 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 23 Oct 2024 13:05:07 -0600 Subject: [PATCH 35/70] Make lfmcmc constructor more readable --- R/cpp11.R | 4 ++-- src/cpp11.cpp | 6 +++--- src/lfmcmc.cpp | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/R/cpp11.R b/R/cpp11.R index 110cb1cd..626254a7 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(m) { - .Call(`_epiworldR_LFMCMC_cpp`, m) +LFMCMC_cpp <- function(model) { + .Call(`_epiworldR_LFMCMC_cpp`, model) } run_lfmcmc_cpp <- function(lfmcmc, params_init_, n_samples_, epsilon_) { diff --git a/src/cpp11.cpp b/src/cpp11.cpp index f4dd141f..d8c55bed 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(SEXP m); -extern "C" SEXP _epiworldR_LFMCMC_cpp(SEXP m) { +SEXP LFMCMC_cpp(SEXP model); +extern "C" SEXP _epiworldR_LFMCMC_cpp(SEXP model) { BEGIN_CPP11 - return cpp11::as_sexp(LFMCMC_cpp(cpp11::as_cpp>(m))); + return cpp11::as_sexp(LFMCMC_cpp(cpp11::as_cpp>(model))); END_CPP11 } // lfmcmc.cpp diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 44c466bd..017d4b89 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -16,13 +16,13 @@ using namespace epiworld; [[cpp11::register]] SEXP LFMCMC_cpp( - SEXP m + SEXP model ) { WrapLFMCMC(lfmcmc_ptr)( new LFMCMC() ); - lfmcmc_ptr->set_rand_engine(cpp11::external_pointer>(m)->get_rand_endgine()); + lfmcmc_ptr->set_rand_engine(cpp11::external_pointer>(model)->get_rand_endgine()); return lfmcmc_ptr; } From 055a464302ea1a81c062edccee441dccf6e78f73 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 23 Oct 2024 14:26:52 -0600 Subject: [PATCH 36/70] Add factory methods for norm_reflective proposal function and gaussian kernel function --- NAMESPACE | 2 + R/LFMCMC.R | 17 +++++ R/cpp11.R | 8 +++ man/LFMCMC.Rd | 16 +++++ src/cpp11.cpp | 16 +++++ src/lfmcmc.cpp | 102 +++++++++++++++++++++++++++++ vignettes/likelihood-free-mcmc.Rmd | 92 +++++++++++++++++++------- 7 files changed, 230 insertions(+), 23 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 38fb75ea..8276ec67 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -169,6 +169,8 @@ export(has_tool) export(has_virus) export(initial_states) export(load_agents_entities_ties) +export(make_kernel_fun_gaussian_lfmcmc) +export(make_proposal_norm_reflective_lfmcmc) export(make_saver) export(plot_generation_time) export(plot_incidence) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 1bee4411..26ac02bf 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -163,3 +163,20 @@ print.epiworld_lfmcmc <- function(x, ...) { print_lfmcmc_cpp(x) invisible(x) } + +#' @rdname LFMCMC +#' @param scale Scale of the normal kernel +#' @param lb Lower bound (applies the same to all parameters) +#' @param ub Upper bound (applies the same to all parameters) +#' @returns The norm reflective LFMCMC proposal function +#' @export +make_proposal_norm_reflective_lfmcmc <- function(scale, lb, ub) { + invisible(make_proposal_norm_reflective_cpp(scale, lb, ub)) +} + +#' @rdname LFMCMC +#' @returns The gaussian LFMCMC kernel function +#' @export +make_kernel_fun_gaussian_lfmcmc <- function() { + invisible(make_kernel_fun_gaussian_cpp()) +} diff --git a/R/cpp11.R b/R/cpp11.R index 626254a7..92e2687e 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -284,6 +284,14 @@ print_lfmcmc_cpp <- function(lfmcmc) { .Call(`_epiworldR_print_lfmcmc_cpp`, lfmcmc) } +make_proposal_norm_reflective_cpp <- function(scale, lb, ub) { + .Call(`_epiworldR_make_proposal_norm_reflective_cpp`, scale, lb, ub) +} + +make_kernel_fun_gaussian_cpp <- function() { + .Call(`_epiworldR_make_kernel_fun_gaussian_cpp`) +} + print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index c908db67..2c745a99 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -14,6 +14,8 @@ \alias{set_par_names} \alias{set_stats_names} \alias{print.epiworld_lfmcmc} +\alias{make_proposal_norm_reflective_lfmcmc} +\alias{make_kernel_fun_gaussian_lfmcmc} \title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} \usage{ LFMCMC(model) @@ -39,6 +41,10 @@ set_par_names(lfmcmc, names) set_stats_names(lfmcmc, names) \method{print}{epiworld_lfmcmc}(x, ...) + +make_proposal_norm_reflective_lfmcmc(scale, lb, ub) + +make_kernel_fun_gaussian_lfmcmc() } \arguments{ \item{model}{A model of class \link{epiworld_model}} @@ -64,6 +70,12 @@ set_stats_names(lfmcmc, names) \item{x}{LFMCMC model to print} \item{...}{Ignored} + +\item{scale}{Scale of the normal kernel} + +\item{lb}{Lower bound (applies the same to all parameters)} + +\item{ub}{Upper bound (applies the same to all parameters)} } \value{ \itemize{ @@ -91,6 +103,10 @@ The lfmcmc model with the parameter names added The lfmcmc model with the stats names added The lfmcmc model + +The norm reflective LFMCMC proposal function + +The gaussian LFMCMC kernel function } \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) diff --git a/src/cpp11.cpp b/src/cpp11.cpp index d8c55bed..0baceffe 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -502,6 +502,20 @@ extern "C" SEXP _epiworldR_print_lfmcmc_cpp(SEXP lfmcmc) { return cpp11::as_sexp(print_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } +// lfmcmc.cpp +SEXP make_proposal_norm_reflective_cpp(epiworld_double scale, epiworld_double lb, epiworld_double ub); +extern "C" SEXP _epiworldR_make_proposal_norm_reflective_cpp(SEXP scale, SEXP lb, SEXP ub) { + BEGIN_CPP11 + return cpp11::as_sexp(make_proposal_norm_reflective_cpp(cpp11::as_cpp>(scale), cpp11::as_cpp>(lb), cpp11::as_cpp>(ub))); + END_CPP11 +} +// lfmcmc.cpp +SEXP make_kernel_fun_gaussian_cpp(); +extern "C" SEXP _epiworldR_make_kernel_fun_gaussian_cpp() { + BEGIN_CPP11 + return cpp11::as_sexp(make_kernel_fun_gaussian_cpp()); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1101,6 +1115,8 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_has_virus_cpp", (DL_FUNC) &_epiworldR_has_virus_cpp, 2}, {"_epiworldR_initial_states_cpp", (DL_FUNC) &_epiworldR_initial_states_cpp, 2}, {"_epiworldR_load_agents_entities_ties_cpp", (DL_FUNC) &_epiworldR_load_agents_entities_ties_cpp, 3}, + {"_epiworldR_make_kernel_fun_gaussian_cpp", (DL_FUNC) &_epiworldR_make_kernel_fun_gaussian_cpp, 0}, + {"_epiworldR_make_proposal_norm_reflective_cpp", (DL_FUNC) &_epiworldR_make_proposal_norm_reflective_cpp, 3}, {"_epiworldR_make_saver_cpp", (DL_FUNC) &_epiworldR_make_saver_cpp, 10}, {"_epiworldR_print_agent_cpp", (DL_FUNC) &_epiworldR_print_agent_cpp, 3}, {"_epiworldR_print_agent_tools_cpp", (DL_FUNC) &_epiworldR_print_agent_tools_cpp, 1}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 017d4b89..14386492 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -214,4 +214,106 @@ SEXP print_lfmcmc_cpp( return lfmcmc; } +// Factory methods +inline LFMCMCProposalFun make_proposal_norm_reflective( + epiworld_double scale, + epiworld_double lb, + epiworld_double ub +) { + + LFMCMCProposalFun fun = + [scale,lb,ub]( + std::vector< epiworld_double >& params_now, + const std::vector< epiworld_double >& params_prev, + LFMCMC* m + ) { + + // Making the proposal + for (size_t p = 0u; p < m->get_n_parameters(); ++p) + params_now[p] = params_prev[p] + m->rnorm() * scale; + + // Checking boundaries + epiworld_double d = ub - lb; + int odd; + epiworld_double d_above, d_below; + for (auto & p : params_now) + { + + // Correcting if parameter goes above the upper bound + if (p > ub) + { + d_above = p - ub; + odd = static_cast(std::floor(d_above / d)) % 2; + d_above = d_above - std::floor(d_above / d) * d; + + p = (lb + d_above) * odd + + (ub - d_above) * (1 - odd); + + // Correcting if parameter goes below upper bound + } else if (p < lb) + { + d_below = lb - p; + int odd = static_cast(std::floor(d_below / d)) % 2; + d_below = d_below - std::floor(d_below / d) * d; + + p = (ub - d_below) * odd + + (lb + d_below) * (1 - odd); + } + + } + + #ifdef EPI_DEBUG + for (auto & p : params_now) + if (p < lb || p > ub) + throw std::range_error("The parameter is out of bounds."); + #endif + + + return; + + }; + + return fun; +} + +inline epiworld_double kernel_fun_gaussian( + const std::vector< epiworld_double >& stats_now, + const std::vector< epiworld_double >& stats_obs, + epiworld_double epsilon, + LFMCMC* m +) { + + epiworld_double ans = 0.0; + for (size_t p = 0u; p < m->get_n_parameters(); ++p) + ans += std::pow(stats_obs[p] - stats_now[p], 2.0); + + return std::exp( + -.5 * (ans/std::pow(1 + std::pow(epsilon, 2.0)/3.0, 2.0)) + ) / sqrt2pi() ; + +} + +[[cpp11::register]] +SEXP make_proposal_norm_reflective_cpp( + epiworld_double scale, + epiworld_double lb, + epiworld_double ub +) { + LFMCMCProposalFun propfun = make_proposal_norm_reflective(scale, lb, ub); + + return cpp11::external_pointer>( + new LFMCMCProposalFun(propfun) + ); +} + +[[cpp11::register]] +SEXP make_kernel_fun_gaussian_cpp() { + + LFMCMCKernelFun kernelfun = kernel_fun_gaussian; + + return cpp11::external_pointer>( + new LFMCMCKernelFun(kernelfun) + ); +} + #undef WrapLFMCMC diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index d90f1bb5..b2ba3c43 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -56,10 +56,10 @@ print(model_sir) ## Extract Observed data ```{r extract-obs-data} -obs_data <- as.integer(get_today_total(model_sir)) +obs_data <- unname(as.integer(get_today_total(model_sir))) ``` -## Setup LFMCMC +## Setup LFMCMC Functions ```{r lfmcmc-setup} # Define Simulation Function simfun <- function(params, m) { @@ -74,43 +74,89 @@ simfun <- function(params, m) { res <- get_today_total(model_sir) return(res) } -# TODO: Define Summary Function + +# Define Summary Function sumfun <- function(res, dat, m) { - # if (length(res) == 0) - # res.resize(data.size()) + if (length(res) == 0) { + res <- numeric(length(dat)) + } - # for (i in dat.size()) - # res[i] = static_cast(dat[i]) + for (i in seq_along(dat)) { + res[i] <- as.numeric(dat[i]) + } - return + return() } -# TODO: Define Proposal Function + +# Define Proposal Function propfun <- function(params_now, params_prev, m) { - return + # Make proposal norm reflective + scale <- as.double(0.5) + lb <- as.double(0) + ub <- as.double(1) + + # Making the proposal + params_now <- params_prev + rnorm(length(params_prev)) * scale + + # Checking boundaries + d <- ub - lb + for (i in seq_along(params_now)) { + # Correcting if parameter goes above the upper bound + if (params_now[i] > ub) { + d_above <- params_now[i] - ub + odd <- floor(d_above / d) %% 2 + d_above <- d_above - floor(d_above / d) * d + + params_now[i] <- (lb + d_above) * odd + (ub - d_above) * (1 - odd) + + # Correcting if parameter goes below lower bound + } else if (params_now[i] < lb) { + d_below <- lb - params_now[i] + odd <- floor(d_below / d) %% 2 + d_below <- d_below - floor(d_below / d) * d + + params_now[i] <- (ub - d_below) * odd + (lb + d_below) * (1 - odd) + } + } + return() } -# TODO: Define Kernel Function -kernfun <- function() { + +# Define Kernel Function +kernfun <- function( + stats_now, + stats_obs, + epsilon, + m + ) { + return(1.0) } # Set initial parameters -par0 <- c(.5, .5) +par0 <- as.double(c(0.5, 0.5)) ``` -## Run LFMCMC -```{r lfmcmc-run} -# TODO: make these work +## Init LFMCMC +```{r lfmcmc-init} lfmcmc_model <- LFMCMC(model_sir) |> set_simulation_fun(simfun) |> set_summary_fun(sumfun) |> - set_proposal_fun(propfun) |> - set_kernel_fun(kernfun) |> + set_proposal_fun(make_proposal_norm_reflective_lfmcmc(0.5, 0, 1)) |> + set_kernel_fun(make_kernel_fun_gaussian_lfmcmc()) |> set_observed_data(obs_data) -# run_lfmcmc(par0, 2000, 1) +``` + +## Run LFMCMC +```{r lfmcmc-run} +# run_lfmcmc( +# lfmcmc = lfmcmc_model, +# params_init_ = par0, +# n_samples_ = 2000, +# epsilon_ = 1.0 +# ) -# lfmcmc_model +# set_stats_names(lfmcmc_model, get_states(model_sir)) +# set_par_names(lfmcmc_model, c("Immune recovery", "Infectiousness")) -# lfmcmc_model <- set_par_names(c("Immune recovery", "Infectiousness")) |> -# set_stats_names(get_states(model_sir)) |> -# print() +print(lfmcmc_model) ``` From eacdc22eb7e27203df641a564a80fd58c8a1446d Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 23 Oct 2024 14:28:04 -0600 Subject: [PATCH 37/70] Delete prop and kernel function defs after using factory methods --- vignettes/likelihood-free-mcmc.Rmd | 44 ------------------------------ 1 file changed, 44 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index b2ba3c43..b835bf9a 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -88,50 +88,6 @@ sumfun <- function(res, dat, m) { return() } -# Define Proposal Function -propfun <- function(params_now, params_prev, m) { - # Make proposal norm reflective - scale <- as.double(0.5) - lb <- as.double(0) - ub <- as.double(1) - - # Making the proposal - params_now <- params_prev + rnorm(length(params_prev)) * scale - - # Checking boundaries - d <- ub - lb - for (i in seq_along(params_now)) { - # Correcting if parameter goes above the upper bound - if (params_now[i] > ub) { - d_above <- params_now[i] - ub - odd <- floor(d_above / d) %% 2 - d_above <- d_above - floor(d_above / d) * d - - params_now[i] <- (lb + d_above) * odd + (ub - d_above) * (1 - odd) - - # Correcting if parameter goes below lower bound - } else if (params_now[i] < lb) { - d_below <- lb - params_now[i] - odd <- floor(d_below / d) %% 2 - d_below <- d_below - floor(d_below / d) * d - - params_now[i] <- (ub - d_below) * odd + (lb + d_below) * (1 - odd) - } - } - return() -} - -# Define Kernel Function -kernfun <- function( - stats_now, - stats_obs, - epsilon, - m - ) { - - return(1.0) -} - # Set initial parameters par0 <- as.double(c(0.5, 0.5)) ``` From cb8988571f4602217fa29ce7016a30a720cb5f62 Mon Sep 17 00:00:00 2001 From: Andrew Date: Wed, 23 Oct 2024 14:33:08 -0600 Subject: [PATCH 38/70] Add cinttypes to .vscode/settings.json --- .vscode/settings.json | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.vscode/settings.json b/.vscode/settings.json index b4549178..296aa280 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -54,7 +54,8 @@ "stdexcept": "cpp", "streambuf": "cpp", "typeinfo": "cpp", - "thread": "cpp" + "thread": "cpp", + "cinttypes": "cpp" }, "editor.indentSize": "tabSize", "[r]": { From 20bb6f3147a409c9efc4c38bfa846c232b76c9e6 Mon Sep 17 00:00:00 2001 From: Andrew Date: Thu, 24 Oct 2024 08:18:48 -0600 Subject: [PATCH 39/70] Minor tweaks to lfmcmc vignette simfun --- vignettes/likelihood-free-mcmc.Rmd | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index b835bf9a..1a231062 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -63,15 +63,15 @@ obs_data <- unname(as.integer(get_today_total(model_sir))) ```{r lfmcmc-setup} # Define Simulation Function simfun <- function(params, m) { - set_param(model_sir, "Recovery Rate", params[0]) - set_param(model_sir, "Transmission Rate", params[1]) + set_param(model_sir, "Recovery Rate", params[1]) + set_param(model_sir, "Transmission Rate", params[2]) reset(model_sir) run( model_sir, ndays = 50, seed = model_seed ) - res <- get_today_total(model_sir) + res <- unname(as.integer(get_today_total(model_sir))) return(res) } @@ -87,9 +87,6 @@ sumfun <- function(res, dat, m) { return() } - -# Set initial parameters -par0 <- as.double(c(0.5, 0.5)) ``` ## Init LFMCMC @@ -104,12 +101,16 @@ lfmcmc_model <- LFMCMC(model_sir) |> ## Run LFMCMC ```{r lfmcmc-run} -# run_lfmcmc( -# lfmcmc = lfmcmc_model, -# params_init_ = par0, -# n_samples_ = 2000, -# epsilon_ = 1.0 -# ) +# Set initial parameters +par0 <- as.double(c(0.5, 0.5)) + +# Run LFMCMC +run_lfmcmc( + lfmcmc = lfmcmc_model, + params_init_ = par0, + n_samples_ = 2000, + epsilon_ = 1.0 +) # set_stats_names(lfmcmc_model, get_states(model_sir)) # set_par_names(lfmcmc_model, c("Immune recovery", "Infectiousness")) From 3d566f187138e90ab056960d50ef22a5241b6e8d Mon Sep 17 00:00:00 2001 From: "George G. Vega Yon" Date: Thu, 24 Oct 2024 11:01:31 -0600 Subject: [PATCH 40/70] Minor changes and adding valgrind to docker --- .devcontainer/Dockerfile | 2 ++ src/lfmcmc.cpp | 3 ++- vignettes/likelihood-free-mcmc.Rmd | 11 ++--------- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index 1c71422e..2ba30ac7 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -10,4 +10,6 @@ RUN install2.r cpp11 roxygen2 tinytest data.table netplot \ RUN install2.r languageserver +RUN apt-get update && apt-get install --no-install-recommends -y valgrind + CMD ["bash"] diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 14386492..faff5463 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -114,7 +114,8 @@ SEXP create_LFMCMCSummaryFun_cpp( LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { WrapLFMCMC(lfmcmc_ptr)(model); - fun(res, dat, lfmcmc_ptr); + auto res_tmp = cpp11::doubles(fun(dat, lfmcmc_ptr)); + res.assign(res_tmp.begin(), res_tmp.end()); return; }; diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 1a231062..dd5e3f73 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -76,16 +76,9 @@ simfun <- function(params, m) { } # Define Summary Function -sumfun <- function(res, dat, m) { - if (length(res) == 0) { - res <- numeric(length(dat)) - } +sumfun <- function(dat, m) { - for (i in seq_along(dat)) { - res[i] <- as.numeric(dat[i]) - } - - return() + return(dat) } ``` From 108621aa69a3657b8ddd77cd4689d9eb63f43893 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Thu, 24 Oct 2024 14:14:10 -0600 Subject: [PATCH 41/70] Add simpler use proposal/kernel functions --- NAMESPACE | 2 ++ R/LFMCMC.R | 18 ++++++++++++++++++ R/cpp11.R | 8 ++++++++ man/LFMCMC.Rd | 12 +++++++++++- src/cpp11.cpp | 16 ++++++++++++++++ src/lfmcmc.cpp | 28 +++++++++++++++++++++++++++- vignettes/likelihood-free-mcmc.Rmd | 19 +++++++++++-------- 7 files changed, 93 insertions(+), 10 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8276ec67..47d7f986 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -228,6 +228,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) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 26ac02bf..2220b6dd 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -180,3 +180,21 @@ make_proposal_norm_reflective_lfmcmc <- function(scale, lb, ub) { make_kernel_fun_gaussian_lfmcmc <- function() { invisible(make_kernel_fun_gaussian_cpp()) } + +#' @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 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) +} diff --git a/R/cpp11.R b/R/cpp11.R index 92e2687e..f9137946 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -292,6 +292,14 @@ make_kernel_fun_gaussian_cpp <- function() { .Call(`_epiworldR_make_kernel_fun_gaussian_cpp`) } +use_proposal_norm_reflective_cpp <- function(lfmcmc) { + .Call(`_epiworldR_use_proposal_norm_reflective_cpp`, lfmcmc) +} + +use_kernel_fun_gaussian_cpp <- function(lfmcmc) { + .Call(`_epiworldR_use_kernel_fun_gaussian_cpp`, lfmcmc) +} + print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 2c745a99..29dc58ff 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -16,6 +16,8 @@ \alias{print.epiworld_lfmcmc} \alias{make_proposal_norm_reflective_lfmcmc} \alias{make_kernel_fun_gaussian_lfmcmc} +\alias{use_proposal_norm_reflective} +\alias{use_kernel_fun_gaussian} \title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} \usage{ LFMCMC(model) @@ -45,11 +47,15 @@ set_stats_names(lfmcmc, names) make_proposal_norm_reflective_lfmcmc(scale, lb, ub) make_kernel_fun_gaussian_lfmcmc() + +use_proposal_norm_reflective(lfmcmc) + +use_kernel_fun_gaussian(lfmcmc) } \arguments{ \item{model}{A model of class \link{epiworld_model}} -\item{lfmcmc}{LFMCMC model} +\item{lfmcmc}{The LFMCMC model} \item{params_init_}{Initial model parameters} @@ -107,6 +113,10 @@ The lfmcmc model The norm reflective LFMCMC proposal function The gaussian LFMCMC kernel function + +The LFMCMC model with proposal function set to norm reflective + +The LFMCMC model with kernel function set to gaussian } \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 0baceffe..d8adeeeb 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -516,6 +516,20 @@ extern "C" SEXP _epiworldR_make_kernel_fun_gaussian_cpp() { return cpp11::as_sexp(make_kernel_fun_gaussian_cpp()); END_CPP11 } +// lfmcmc.cpp +SEXP use_proposal_norm_reflective_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_use_proposal_norm_reflective_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(use_proposal_norm_reflective_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp +SEXP use_kernel_fun_gaussian_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_use_kernel_fun_gaussian_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(use_kernel_fun_gaussian_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1179,6 +1193,8 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_size_cpp", (DL_FUNC) &_epiworldR_size_cpp, 1}, {"_epiworldR_tool_cpp", (DL_FUNC) &_epiworldR_tool_cpp, 7}, {"_epiworldR_tool_fun_logit_cpp", (DL_FUNC) &_epiworldR_tool_fun_logit_cpp, 3}, + {"_epiworldR_use_kernel_fun_gaussian_cpp", (DL_FUNC) &_epiworldR_use_kernel_fun_gaussian_cpp, 1}, + {"_epiworldR_use_proposal_norm_reflective_cpp", (DL_FUNC) &_epiworldR_use_proposal_norm_reflective_cpp, 1}, {"_epiworldR_verbose_off_cpp", (DL_FUNC) &_epiworldR_verbose_off_cpp, 1}, {"_epiworldR_verbose_on_cpp", (DL_FUNC) &_epiworldR_verbose_on_cpp, 1}, {"_epiworldR_virus_cpp", (DL_FUNC) &_epiworldR_virus_cpp, 8}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index faff5463..99e9e0d3 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -86,8 +86,13 @@ SEXP create_LFMCMCSimFun_cpp( LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { WrapLFMCMC(lfmcmc_ptr)(model); + // auto res_tmp = cpp11::integers(fun(params, lfmcmc_ptr)); + // TData_default res; + // res.assign(res_tmp.begin(), res_tmp.end()); + // return res; cpp11::external_pointer res(fun(params, lfmcmc_ptr)); return *res; + }; return cpp11::external_pointer>( @@ -114,7 +119,9 @@ SEXP create_LFMCMCSummaryFun_cpp( LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { WrapLFMCMC(lfmcmc_ptr)(model); - auto res_tmp = cpp11::doubles(fun(dat, lfmcmc_ptr)); + // fun(dat, lfmcmc_ptr); + // Still throws: Invalid input type, expected 'double' actual 'integer' + auto res_tmp = cpp11::as_cpp>(cpp11::doubles(fun(dat, lfmcmc_ptr))); res.assign(res_tmp.begin(), res_tmp.end()); return; }; @@ -317,4 +324,23 @@ SEXP make_kernel_fun_gaussian_cpp() { ); } +// Testing functions +[[cpp11::register]] +SEXP use_proposal_norm_reflective_cpp( + SEXP lfmcmc +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_proposal_fun(make_proposal_norm_reflective(0.5, 0, 1)); + return lfmcmc; +} + +[[cpp11::register]] +SEXP use_kernel_fun_gaussian_cpp( + SEXP lfmcmc +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_kernel_fun(kernel_fun_gaussian); + return lfmcmc; +} + #undef WrapLFMCMC diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index dd5e3f73..1300f2e1 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -77,7 +77,6 @@ simfun <- function(params, m) { # Define Summary Function sumfun <- function(dat, m) { - return(dat) } ``` @@ -87,22 +86,26 @@ sumfun <- function(dat, m) { lfmcmc_model <- LFMCMC(model_sir) |> set_simulation_fun(simfun) |> set_summary_fun(sumfun) |> - set_proposal_fun(make_proposal_norm_reflective_lfmcmc(0.5, 0, 1)) |> - set_kernel_fun(make_kernel_fun_gaussian_lfmcmc()) |> + use_proposal_norm_reflective() |> + use_kernel_fun_gaussian() |> set_observed_data(obs_data) ``` -## Run LFMCMC -```{r lfmcmc-run} +## Set LFMCMC params +```{r lfmcmc-params} # Set initial parameters par0 <- as.double(c(0.5, 0.5)) +n_samp <- 2000 +epsil <- as.double(1.0) +``` -# Run LFMCMC +## Run LFMCMC +```{r lfmcmc-run} run_lfmcmc( lfmcmc = lfmcmc_model, params_init_ = par0, - n_samples_ = 2000, - epsilon_ = 1.0 + n_samples_ = n_samp, + epsilon_ = epsil ) # set_stats_names(lfmcmc_model, get_states(model_sir)) From 634d7832323ce115569a9647b8b58a0db1152cbe Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Thu, 24 Oct 2024 14:30:33 -0600 Subject: [PATCH 42/70] Clean up create sum and create sim fun in lfmcmc.cpp --- src/lfmcmc.cpp | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 99e9e0d3..9020db7a 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -86,13 +86,8 @@ SEXP create_LFMCMCSimFun_cpp( LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { WrapLFMCMC(lfmcmc_ptr)(model); - // auto res_tmp = cpp11::integers(fun(params, lfmcmc_ptr)); - // TData_default res; - // res.assign(res_tmp.begin(), res_tmp.end()); - // return res; - cpp11::external_pointer res(fun(params, lfmcmc_ptr)); - return *res; - + TData_default res = cpp11::as_cpp(cpp11::integers(fun(params, lfmcmc_ptr))); + return res; }; return cpp11::external_pointer>( @@ -119,8 +114,6 @@ SEXP create_LFMCMCSummaryFun_cpp( LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { WrapLFMCMC(lfmcmc_ptr)(model); - // fun(dat, lfmcmc_ptr); - // Still throws: Invalid input type, expected 'double' actual 'integer' auto res_tmp = cpp11::as_cpp>(cpp11::doubles(fun(dat, lfmcmc_ptr))); res.assign(res_tmp.begin(), res_tmp.end()); return; From 67e4137ce77c09224271d5f14fe5ba6ae78af2de Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Tue, 29 Oct 2024 11:14:11 -0600 Subject: [PATCH 43/70] Remove 'create' lfmcmc methods to instead create the function within the 'set' methods and add temp test code --- R/cpp11.R | 16 ---- src/cpp11.cpp | 48 ++--------- src/lfmcmc.cpp | 225 ++++++++++++++++++++++++++++++++++--------------- 3 files changed, 166 insertions(+), 123 deletions(-) diff --git a/R/cpp11.R b/R/cpp11.R index f9137946..6ec15427 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -232,34 +232,18 @@ set_observed_data_cpp <- function(lfmcmc, observed_data_) { .Call(`_epiworldR_set_observed_data_cpp`, lfmcmc, observed_data_) } -create_LFMCMCProposalFun_cpp <- function(fun) { - .Call(`_epiworldR_create_LFMCMCProposalFun_cpp`, fun) -} - set_proposal_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_proposal_fun_cpp`, lfmcmc, fun) } -create_LFMCMCSimFun_cpp <- function(fun) { - .Call(`_epiworldR_create_LFMCMCSimFun_cpp`, fun) -} - set_simulation_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_simulation_fun_cpp`, lfmcmc, fun) } -create_LFMCMCSummaryFun_cpp <- function(fun) { - .Call(`_epiworldR_create_LFMCMCSummaryFun_cpp`, fun) -} - set_summary_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_summary_fun_cpp`, lfmcmc, fun) } -create_LFMCMCKernelFun_cpp <- function(fun) { - .Call(`_epiworldR_create_LFMCMCKernelFun_cpp`, fun) -} - set_kernel_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_kernel_fun_cpp`, lfmcmc, fun) } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index d8adeeeb..c1ab43fd 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -412,59 +412,31 @@ extern "C" SEXP _epiworldR_set_observed_data_cpp(SEXP lfmcmc, SEXP observed_data END_CPP11 } // lfmcmc.cpp -SEXP create_LFMCMCProposalFun_cpp(cpp11::function fun); -extern "C" SEXP _epiworldR_create_LFMCMCProposalFun_cpp(SEXP fun) { - BEGIN_CPP11 - return cpp11::as_sexp(create_LFMCMCProposalFun_cpp(cpp11::as_cpp>(fun))); - END_CPP11 -} -// lfmcmc.cpp -SEXP set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun); +SEXP set_proposal_fun_cpp(SEXP lfmcmc, cpp11::function fun); extern "C" SEXP _epiworldR_set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 - return cpp11::as_sexp(set_proposal_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); - END_CPP11 -} -// lfmcmc.cpp -SEXP create_LFMCMCSimFun_cpp(cpp11::function fun); -extern "C" SEXP _epiworldR_create_LFMCMCSimFun_cpp(SEXP fun) { - BEGIN_CPP11 - return cpp11::as_sexp(create_LFMCMCSimFun_cpp(cpp11::as_cpp>(fun))); + return cpp11::as_sexp(set_proposal_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); END_CPP11 } // lfmcmc.cpp -SEXP set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun); +SEXP set_simulation_fun_cpp(SEXP lfmcmc, cpp11::function fun); extern "C" SEXP _epiworldR_set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 - return cpp11::as_sexp(set_simulation_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); + return cpp11::as_sexp(set_simulation_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); END_CPP11 } // lfmcmc.cpp -SEXP create_LFMCMCSummaryFun_cpp(cpp11::function fun); -extern "C" SEXP _epiworldR_create_LFMCMCSummaryFun_cpp(SEXP fun) { - BEGIN_CPP11 - return cpp11::as_sexp(create_LFMCMCSummaryFun_cpp(cpp11::as_cpp>(fun))); - END_CPP11 -} -// lfmcmc.cpp -SEXP set_summary_fun_cpp(SEXP lfmcmc, SEXP fun); +SEXP set_summary_fun_cpp(SEXP lfmcmc, cpp11::function fun); extern "C" SEXP _epiworldR_set_summary_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 - return cpp11::as_sexp(set_summary_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); - END_CPP11 -} -// lfmcmc.cpp -SEXP create_LFMCMCKernelFun_cpp(cpp11::function fun); -extern "C" SEXP _epiworldR_create_LFMCMCKernelFun_cpp(SEXP fun) { - BEGIN_CPP11 - return cpp11::as_sexp(create_LFMCMCKernelFun_cpp(cpp11::as_cpp>(fun))); + return cpp11::as_sexp(set_summary_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); END_CPP11 } // lfmcmc.cpp -SEXP set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun); +SEXP set_kernel_fun_cpp(SEXP lfmcmc, cpp11::function fun); extern "C" SEXP _epiworldR_set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 - return cpp11::as_sexp(set_kernel_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); + return cpp11::as_sexp(set_kernel_fun_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(fun))); END_CPP11 } // lfmcmc.cpp @@ -1077,10 +1049,6 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_agents_smallworld_cpp", (DL_FUNC) &_epiworldR_agents_smallworld_cpp, 5}, {"_epiworldR_change_state_cpp", (DL_FUNC) &_epiworldR_change_state_cpp, 4}, {"_epiworldR_clone_model_cpp", (DL_FUNC) &_epiworldR_clone_model_cpp, 1}, - {"_epiworldR_create_LFMCMCKernelFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCKernelFun_cpp, 1}, - {"_epiworldR_create_LFMCMCProposalFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCProposalFun_cpp, 1}, - {"_epiworldR_create_LFMCMCSimFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCSimFun_cpp, 1}, - {"_epiworldR_create_LFMCMCSummaryFun_cpp", (DL_FUNC) &_epiworldR_create_LFMCMCSummaryFun_cpp, 1}, {"_epiworldR_distribute_entity_randomly_cpp", (DL_FUNC) &_epiworldR_distribute_entity_randomly_cpp, 3}, {"_epiworldR_distribute_entity_to_set_cpp", (DL_FUNC) &_epiworldR_distribute_entity_to_set_cpp, 1}, {"_epiworldR_distribute_tool_randomly_cpp", (DL_FUNC) &_epiworldR_distribute_tool_randomly_cpp, 2}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 9020db7a..6c56186a 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -1,6 +1,7 @@ #include "cpp11.hpp" #include "cpp11/external_pointer.hpp" #include "cpp11/r_vector.hpp" +#include "cpp11/sexp.hpp" #include "epiworld-common.h" @@ -50,116 +51,206 @@ SEXP set_observed_data_cpp( return lfmcmc; } +// TODO: Uncomment if needed, delete otherwise // LFMCMC Proposal Function +// [[cpp11::register]] +// SEXP create_LFMCMCProposalFun_cpp( +// cpp11::function fun +// ) { + +// LFMCMCProposalFun fun_call = [fun](std::vector< epiworld_double >& params_now,const std::vector< epiworld_double >& params_prev, LFMCMC* model) -> void { +// WrapLFMCMC(lfmcmc_ptr)(model); +// fun(params_now, params_prev, lfmcmc_ptr); +// return; +// }; + +// return cpp11::external_pointer>( +// new LFMCMCProposalFun(fun_call) +// ); +// } + [[cpp11::register]] -SEXP create_LFMCMCProposalFun_cpp( +SEXP set_proposal_fun_cpp( + SEXP lfmcmc, cpp11::function fun - ) { +) { LFMCMCProposalFun fun_call = [fun](std::vector< epiworld_double >& params_now,const std::vector< epiworld_double >& params_prev, LFMCMC* model) -> void { - WrapLFMCMC(lfmcmc_ptr)(model); - fun(params_now, params_prev, lfmcmc_ptr); + WrapLFMCMC(model_ptr)(model); + fun(params_now, params_prev, model_ptr); return; }; - return cpp11::external_pointer>( - new LFMCMCProposalFun(fun_call) - ); -} - -[[cpp11::register]] -SEXP set_proposal_fun_cpp( - SEXP lfmcmc, - SEXP fun -) { - cpp11::external_pointer> fun_ptr = create_LFMCMCProposalFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_proposal_fun(*fun_ptr); + + // TODO: Uncomment if needed, delete otherwise + // cpp11::external_pointer> fun_ptr = create_LFMCMCProposalFun_cpp(fun); + // lfmcmc_ptr->set_proposal_fun(*fun_ptr); + + lfmcmc_ptr->set_proposal_fun(fun_call); + return lfmcmc; } +// TODO: Uncomment if needed, delete otherwise // LFMCMC Simulation Function +// [[cpp11::register]] +// SEXP create_LFMCMCSimFun_cpp( +// cpp11::function fun +// ) { + +// LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { +// WrapLFMCMC(lfmcmc_ptr)(model); +// TData_default res = cpp11::as_cpp(cpp11::integers(fun(params, lfmcmc_ptr))); +// return res; +// }; + +// return cpp11::external_pointer>( +// new LFMCMCSimFun(fun_call) +// ); +// } + [[cpp11::register]] -SEXP create_LFMCMCSimFun_cpp( +SEXP set_simulation_fun_cpp( + SEXP lfmcmc, cpp11::function fun - ) { +) { LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { - WrapLFMCMC(lfmcmc_ptr)(model); - TData_default res = cpp11::as_cpp(cpp11::integers(fun(params, lfmcmc_ptr))); + WrapLFMCMC(model_ptr)(model); + + // TODO: This was added because of a similar construct in actions.cpp 'globalevent_fun_cpp()' + // It doesn't appear to help at all, so might be removable + cpp11::sexp modelptrs(model_ptr); + modelptrs.attr("class") = "epiworld_lfmcmc"; + + TData_default res = cpp11::as_cpp(cpp11::integers(fun(params, model_ptr))); return res; }; - return cpp11::external_pointer>( - new LFMCMCSimFun(fun_call) - ); -} - -[[cpp11::register]] -SEXP set_simulation_fun_cpp( - SEXP lfmcmc, - SEXP fun -) { - cpp11::external_pointer> fun_ptr = create_LFMCMCSimFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_simulation_fun(*fun_ptr); + + // TODO: Uncomment if needed, delete otherwise + // cpp11::external_pointer> fun_ptr = create_LFMCMCSimFun_cpp(fun); + // lfmcmc_ptr->set_simulation_fun(*fun_ptr); + + lfmcmc_ptr->set_simulation_fun(fun_call); + return lfmcmc; } +// TODO: Uncomment if needed, delete otherwise // LFMCMC Summary Function +// [[cpp11::register]] +// SEXP create_LFMCMCSummaryFun_cpp( +// cpp11::function fun +// ) { + +// LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { +// WrapLFMCMC(lfmcmc_ptr)(model); +// auto res_tmp = cpp11::as_cpp>(cpp11::doubles(fun(dat, lfmcmc_ptr))); +// res.assign(res_tmp.begin(), res_tmp.end()); +// return; +// }; + +// return cpp11::external_pointer>( +// new LFMCMCSummaryFun(fun_call) +// ); +// } + [[cpp11::register]] -SEXP create_LFMCMCSummaryFun_cpp( +SEXP set_summary_fun_cpp( + SEXP lfmcmc, cpp11::function fun - ) { +) { LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { - WrapLFMCMC(lfmcmc_ptr)(model); - auto res_tmp = cpp11::as_cpp>(cpp11::doubles(fun(dat, lfmcmc_ptr))); - res.assign(res_tmp.begin(), res_tmp.end()); + WrapLFMCMC(model_ptr)(model); + + // TODO: This was added because of a similar construct in actions.cpp 'globalevent_fun_cpp()' + // It doesn't appear to help at all, so might be removable + cpp11::sexp modelptrs(model_ptr); + modelptrs.attr("class") = "epiworld_lfmcmc"; + + // TODO: This was added because the memory error seemed linked to the assignment of the 'res' vector + // It comes from the example summary function in the main epiworld (C++) repo + // The .resize() appears to still throw an error in valgrind + // This might need to be removed + if (res.size() == 0u) + res.resize(dat.size()); + + // auto res_1 = fun(dat, model_ptr); + // auto res_2 = cpp11::doubles(res_1); + // auto res_tmp = cpp11::as_cpp>(res_2); + + // TODO: Originally, this code was all one line and used 'cpp11::doubles' instead of 'cpp11::integers' + // I used integers instead because the errors I was seeing reminded me that 'fun()' as defined in the vignette + // returns a vector ('dat') + // Adding this code resolved the errors I was seeing, but other errors persist so it is possible it wasn't the root cause + auto res_1 = fun(dat, model_ptr); + auto res_2 = cpp11::integers(res_1); + + // TODO: This is also taken from the example summary function in the main epiworld (C++) repo + // I added it to see if it resolved some of the errors associated with 'res' and having the correct type ('double' instead of 'int') + // Adding this code resolved some errors I was seeing, but other errors persist so it is possible it wasn't the root cause + // This might need to be removed in favor of the '.assign()' operation below + // Also, the size_t i < res_2.size() operation throws a warning at compile time, so if it stays, that should be fixed + for (size_t i = 0u; i < res_2.size(); ++i) + res[i] = static_cast< epiworld_double >(res_2[i]); + + // res.assign(res_2.begin(), res_2.end()); + return; }; - return cpp11::external_pointer>( - new LFMCMCSummaryFun(fun_call) - ); -} - -[[cpp11::register]] -SEXP set_summary_fun_cpp( - SEXP lfmcmc, - SEXP fun -) { - cpp11::external_pointer> fun_ptr = create_LFMCMCSummaryFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_summary_fun(*fun_ptr); + + // TODO: Uncomment if needed, delete otherwise + // cpp11::external_pointer> fun_ptr = create_LFMCMCSummaryFun_cpp(fun); + // lfmcmc_ptr->set_summary_fun(*fun_ptr); + + lfmcmc_ptr->set_summary_fun(fun_call); + return lfmcmc; } +// TODO: Uncomment if needed, delete otherwise // LFMCMC Kernel Function +// [[cpp11::register]] +// SEXP create_LFMCMCKernelFun_cpp( +// cpp11::function fun +// ) { + +// LFMCMCKernelFun fun_call = [fun](const std::vector< epiworld_double >& stats_now, const std::vector< epiworld_double >& stats_obs, epiworld_double epsilon, LFMCMC* model) -> epiworld_double { +// WrapLFMCMC(lfmcmc_ptr)(model); +// cpp11::external_pointer res(fun(stats_now, stats_obs, epsilon, lfmcmc_ptr)); +// return *res; +// }; + +// return cpp11::external_pointer>( +// new LFMCMCKernelFun(fun_call) +// ); +// } + [[cpp11::register]] -SEXP create_LFMCMCKernelFun_cpp( +SEXP set_kernel_fun_cpp( + SEXP lfmcmc, cpp11::function fun - ) { - +) { LFMCMCKernelFun fun_call = [fun](const std::vector< epiworld_double >& stats_now, const std::vector< epiworld_double >& stats_obs, epiworld_double epsilon, LFMCMC* model) -> epiworld_double { - WrapLFMCMC(lfmcmc_ptr)(model); - cpp11::external_pointer res(fun(stats_now, stats_obs, epsilon, lfmcmc_ptr)); + WrapLFMCMC(model_ptr)(model); + cpp11::external_pointer res(fun(stats_now, stats_obs, epsilon, model_ptr)); return *res; }; - return cpp11::external_pointer>( - new LFMCMCKernelFun(fun_call) - ); -} - -[[cpp11::register]] -SEXP set_kernel_fun_cpp( - SEXP lfmcmc, - SEXP fun -) { - cpp11::external_pointer> fun_ptr = create_LFMCMCKernelFun_cpp(fun); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_kernel_fun(*fun_ptr); + + // TODO: Uncomment if needed, delete otherwise + // cpp11::external_pointer> fun_ptr = create_LFMCMCKernelFun_cpp(fun); + // lfmcmc_ptr->set_kernel_fun(*fun_ptr); + + lfmcmc_ptr->set_kernel_fun(fun_call); + return lfmcmc; } @@ -169,8 +260,8 @@ SEXP set_rand_engine_lfmcmc_cpp( SEXP lfmcmc, SEXP eng ) { - cpp11::external_pointer eng_ptr(eng); WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + cpp11::external_pointer eng_ptr(eng); lfmcmc_ptr->set_rand_engine(*eng_ptr); return lfmcmc; } From 194ed2d42a88ffcb77351838b48019aa7b4d30b3 Mon Sep 17 00:00:00 2001 From: "George G. Vega Yon" Date: Tue, 29 Oct 2024 12:42:47 -0600 Subject: [PATCH 44/70] New version of epiworld --- .devcontainer/Dockerfile | 2 +- R/cpp11.R | 4 -- inst/include/epiworld/database-bones.hpp | 21 ++++-- inst/include/epiworld/database-meat.hpp | 18 ++++- inst/include/epiworld/epiworld.hpp | 6 +- .../epiworld/math/lfmcmc/lfmcmc-bones.hpp | 12 ++-- .../epiworld/math/lfmcmc/lfmcmc-meat.hpp | 10 +-- inst/include/epiworld/model-bones.hpp | 20 ++---- inst/include/epiworld/model-meat.hpp | 66 ++++++++---------- .../include/epiworld/models/seirconnected.hpp | 67 +++++++++++++++++++ inst/include/epiworld/models/sirconnected.hpp | 58 ++++++++++++++++ inst/include/epiworld/models/surveillance.hpp | 2 +- inst/include/epiworld/progress.hpp | 12 +++- inst/include/epiworld/random_graph.hpp | 6 +- src/cpp11.cpp | 8 --- src/lfmcmc.cpp | 20 +++--- vignettes/likelihood-free-mcmc.Rmd | 6 +- 17 files changed, 229 insertions(+), 109 deletions(-) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index 2ba30ac7..8f990d4c 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -10,6 +10,6 @@ RUN install2.r cpp11 roxygen2 tinytest data.table netplot \ RUN install2.r languageserver -RUN apt-get update && apt-get install --no-install-recommends -y valgrind +RUN apt-get update && apt-get install --no-install-recommends -y valgrind gdb CMD ["bash"] diff --git a/R/cpp11.R b/R/cpp11.R index 6ec15427..eeb3e508 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -248,10 +248,6 @@ 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/inst/include/epiworld/database-bones.hpp b/inst/include/epiworld/database-bones.hpp index 3d64ea00..152ee1a4 100644 --- a/inst/include/epiworld/database-bones.hpp +++ b/inst/include/epiworld/database-bones.hpp @@ -178,6 +178,10 @@ class DataBase { std::vector< int > & counts ) const; + void get_today_transition_matrix( + std::vector< int > & counts + ) const; + void get_hist_total( std::vector< int > * date, std::vector< std::string > * state, @@ -246,10 +250,13 @@ class DataBase { std::string fn_generation_time ) const; + /*** + * @brief Record a transmission event + */ void record_transmission(int i, int j, int virus, int i_expo_date); - size_t get_n_viruses() const; - size_t get_n_tools() const; + size_t get_n_viruses() const; ///< Get the number of viruses + size_t get_n_tools() const; ///< Get the number of tools void set_user_data(std::vector< std::string > names); void add_user_data(std::vector< epiworld_double > x); @@ -288,7 +295,11 @@ class DataBase { /** * Calculates the generating time - * @param agent_id,virus_id,time,gentime vectors where to save the values agent_id + * @param agent_id,virus_id,time,gentime vectors where to save the values + * + * @details + * The generation time is the time between the infection of the source and + * the infection of the target. */ ///@{ void generation_time( @@ -296,11 +307,11 @@ class DataBase { std::vector< int > & virus_id, std::vector< int > & time, std::vector< int > & gentime - ) const; + ) const; ///< Get the generation time void generation_time( std::string fn - ) const; + ) const; ///< Write the generation time to a file ///@} }; diff --git a/inst/include/epiworld/database-meat.hpp b/inst/include/epiworld/database-meat.hpp index 95e641bb..f6d358db 100644 --- a/inst/include/epiworld/database-meat.hpp +++ b/inst/include/epiworld/database-meat.hpp @@ -639,6 +639,18 @@ inline void DataBase::get_hist_tool( } +template +inline void DataBase::get_today_transition_matrix( + std::vector< int > & counts +) const +{ + + counts = transition_matrix; + + return; + +} + template inline void DataBase::get_hist_transition_matrix( std::vector< std::string > & state_from, @@ -995,9 +1007,9 @@ inline void DataBase::write_data( #ifdef EPI_DEBUG EPI_GET_THREAD_ID() << " " << #endif - i << " " << - model->states_labels[from] << " " << - model->states_labels[to] << " " << + i << " \"" << + model->states_labels[from] << "\" \"" << + model->states_labels[to] << "\" " << hist_transition_matrix[i * (ns * ns) + to * ns + from] << "\n"; } diff --git a/inst/include/epiworld/epiworld.hpp b/inst/include/epiworld/epiworld.hpp index 7e8f6624..398bf6c7 100644 --- a/inst/include/epiworld/epiworld.hpp +++ b/inst/include/epiworld/epiworld.hpp @@ -18,8 +18,8 @@ /* Versioning */ #define EPIWORLD_VERSION_MAJOR 0 -#define EPIWORLD_VERSION_MINOR 3 -#define EPIWORLD_VERSION_PATCH 2 +#define EPIWORLD_VERSION_MINOR 4 +#define EPIWORLD_VERSION_PATCH 1 static const int epiworld_version_major = EPIWORLD_VERSION_MAJOR; static const int epiworld_version_minor = EPIWORLD_VERSION_MINOR; @@ -33,7 +33,7 @@ namespace epiworld { #include "misc.hpp" #include "progress.hpp" - // #include "math/summary-stats.hpp" + #include "math/distributions.hpp" #include "math/lfmcmc.hpp" diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp index 6c494b95..60a896f3 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp @@ -116,7 +116,7 @@ class LFMCMC { private: // Random number sampling - std::mt19937 * engine = nullptr; + std::shared_ptr< std::mt19937 > engine = nullptr; std::shared_ptr< std::uniform_real_distribution<> > runifd = std::make_shared< std::uniform_real_distribution<> >(0.0, 1.0); @@ -128,7 +128,7 @@ class LFMCMC { std::make_shared< std::gamma_distribution<> >(); // Process data - TData * observed_data; + TData observed_data; // Information about the size of the problem size_t n_samples; @@ -191,10 +191,10 @@ class LFMCMC { ); LFMCMC() {}; - LFMCMC(TData & observed_data_) : observed_data(&observed_data_) {}; + LFMCMC(const TData & observed_data_) : observed_data(observed_data_) {}; ~LFMCMC() {}; - void set_observed_data(TData & observed_data_) {observed_data = &observed_data_;}; + void set_observed_data(const TData & observed_data_) {observed_data = observed_data_;}; void set_proposal_fun(LFMCMCProposalFun fun); void set_simulation_fun(LFMCMCSimFun fun); void set_summary_fun(LFMCMCSummaryFun fun); @@ -206,8 +206,8 @@ class LFMCMC { * @param eng */ ///@{ - void set_rand_engine(std::mt19937 & eng); - std::mt19937 & get_rand_endgine(); + void set_rand_engine(std::shared_ptr< std::mt19937 > & eng); + std::shared_ptr< std::mt19937 > & get_rand_endgine(); void seed(epiworld_fast_uint s); void set_rand_gamma(epiworld_double alpha, epiworld_double beta); epiworld_double runif(); diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp index 688f4fd0..3984df2a 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp @@ -228,7 +228,7 @@ inline void LFMCMC::run( params_now = params_init; // Computing the baseline sufficient statistics - summary_fun(observed_stats, *observed_data, this); + summary_fun(observed_stats, observed_data, this); n_statistics = observed_stats.size(); // Reserving size @@ -378,9 +378,9 @@ inline void LFMCMC::seed(epiworld_fast_uint s) { } template -inline void LFMCMC::set_rand_engine(std::mt19937 & eng) +inline void LFMCMC::set_rand_engine(std::shared_ptr< std::mt19937 > & eng) { - engine = ŋ + engine = eng; } template @@ -390,9 +390,9 @@ inline void LFMCMC::set_rand_gamma(epiworld_double alpha, epiworld_double } template -inline std::mt19937 & LFMCMC::get_rand_endgine() +inline std::shared_ptr< std::mt19937 > & LFMCMC::get_rand_endgine() { - return *engine; + return engine; } // Step 1: Simulate data diff --git a/inst/include/epiworld/model-bones.hpp b/inst/include/epiworld/model-bones.hpp index 4029f12a..d4055094 100644 --- a/inst/include/epiworld/model-bones.hpp +++ b/inst/include/epiworld/model-bones.hpp @@ -140,7 +140,7 @@ class Model { std::vector< Entity > entities = {}; std::vector< Entity > entities_backup = {}; - std::mt19937 engine; + std::shared_ptr< std::mt19937 > engine = std::make_shared< std::mt19937 >(); std::uniform_real_distribution<> runifd = std::uniform_real_distribution<> (0.0, 1.0); @@ -261,17 +261,6 @@ class Model { virtual ~Model() {}; - void clone_population( - std::vector< Agent > & other_population, - std::vector< Entity > & other_entities, - Model * other_model, - bool & other_directed - ) const ; - - void clone_population( - const Model & other_model - ); - /** * @name Set the backup object * @details `backup` can be used to restore the entire object @@ -285,6 +274,7 @@ class Model { ///@} DataBase & get_db(); + const DataBase & get_db() const; epiworld_double & operator()(std::string pname); size_t size() const; @@ -296,8 +286,8 @@ class Model { * @param s Seed */ ///@{ - void set_rand_engine(std::mt19937 & eng); - std::mt19937 & get_rand_endgine(); + void set_rand_engine(std::shared_ptr< std::mt19937 > & eng); + std::shared_ptr< std::mt19937 > & get_rand_endgine(); void seed(size_t s); void set_rand_norm(epiworld_double mean, epiworld_double sd); void set_rand_unif(epiworld_double a, epiworld_double b); @@ -609,7 +599,7 @@ class Model { // void set_param(size_t k, epiworld_double val); void set_param(std::string pname, epiworld_double val); // epiworld_double par(epiworld_fast_uint k); - epiworld_double par(std::string pname); + epiworld_double par(std::string pname) const; ///@} void get_elapsed( diff --git a/inst/include/epiworld/model-meat.hpp b/inst/include/epiworld/model-meat.hpp index d8d4e978..5df3befb 100644 --- a/inst/include/epiworld/model-meat.hpp +++ b/inst/include/epiworld/model-meat.hpp @@ -495,13 +495,6 @@ inline Model & Model::operator=(const Model & m) for (auto & p : population_backup) p.model = this; - for (auto & e : entities) - e.model = this; - - if (entities_backup.size() != 0) - for (auto & e : entities_backup) - e.model = this; - db = m.db; db.model = this; db.user_data.model = this; @@ -566,6 +559,13 @@ inline DataBase & Model::get_db() return db; } +template +inline const DataBase & Model::get_db() const +{ + return db; +} + + template inline std::vector> & Model::get_agents() { @@ -674,12 +674,6 @@ inline void Model::agents_empty_graph( } -// template -// inline void Model::set_rand_engine(std::mt19937 & eng) -// { -// engine = std::make_shared< std::mt19937 >(eng); -// } - template inline void Model::set_rand_gamma(epiworld_double alpha, epiworld_double beta) { @@ -820,7 +814,7 @@ inline void Model::set_backup() // } template -inline std::mt19937 & Model::get_rand_endgine() +inline std::shared_ptr< std::mt19937 > & Model::get_rand_endgine() { return engine; } @@ -828,86 +822,86 @@ inline std::mt19937 & Model::get_rand_endgine() template inline epiworld_double Model::runif() { // CHECK_INIT() - return runifd(engine); + return runifd(*engine); } template inline epiworld_double Model::runif(epiworld_double a, epiworld_double b) { // CHECK_INIT() - return runifd(engine) * (b - a) + a; + return runifd(*engine) * (b - a) + a; } template inline epiworld_double Model::rnorm() { // CHECK_INIT() - return rnormd(engine); + return rnormd(*engine); } template inline epiworld_double Model::rnorm(epiworld_double mean, epiworld_double sd) { // CHECK_INIT() - return rnormd(engine) * sd + mean; + return rnormd(*engine) * sd + mean; } template inline epiworld_double Model::rgamma() { - return rgammad(engine); + return rgammad(*engine); } template inline epiworld_double Model::rgamma(epiworld_double alpha, epiworld_double beta) { auto old_param = rgammad.param(); rgammad.param(std::gamma_distribution<>::param_type(alpha, beta)); - epiworld_double ans = rgammad(engine); + epiworld_double ans = rgammad(*engine); rgammad.param(old_param); return ans; } template inline epiworld_double Model::rexp() { - return rexpd(engine); + return rexpd(*engine); } template inline epiworld_double Model::rexp(epiworld_double lambda) { auto old_param = rexpd.param(); rexpd.param(std::exponential_distribution<>::param_type(lambda)); - epiworld_double ans = rexpd(engine); + epiworld_double ans = rexpd(*engine); rexpd.param(old_param); return ans; } template inline epiworld_double Model::rlognormal() { - return rlognormald(engine); + return rlognormald(*engine); } template inline epiworld_double Model::rlognormal(epiworld_double mean, epiworld_double shape) { auto old_param = rlognormald.param(); rlognormald.param(std::lognormal_distribution<>::param_type(mean, shape)); - epiworld_double ans = rlognormald(engine); + epiworld_double ans = rlognormald(*engine); rlognormald.param(old_param); return ans; } template inline int Model::rbinom() { - return rbinomd(engine); + return rbinomd(*engine); } template inline int Model::rbinom(int n, epiworld_double p) { auto old_param = rbinomd.param(); rbinomd.param(std::binomial_distribution<>::param_type(n, p)); - epiworld_double ans = rbinomd(engine); + epiworld_double ans = rbinomd(*engine); rbinomd.param(old_param); return ans; } template inline void Model::seed(size_t s) { - this->engine.seed(s); + this->engine->seed(s); } template @@ -1297,7 +1291,7 @@ inline Model & Model::run( this->ndays = ndays; if (seed >= 0) - engine.seed(seed); + engine->seed(seed); array_double_tmp.resize(std::max( size(), @@ -1410,15 +1404,6 @@ inline void Model::run_multiple( // Seeds will be reproducible by default std::vector< int > seeds_n(nexperiments); - // #ifdef EPI_DEBUG - // std::fill( - // seeds_n.begin(), - // seeds_n.end(), - // std::floor( - // runif() * static_cast(std::numeric_limits::max()) - // ) - // ); - // #else for (auto & s : seeds_n) { s = static_cast( @@ -2083,9 +2068,12 @@ inline void Model::set_param(std::string pname, epiworld_double value) // } template -inline epiworld_double Model::par(std::string pname) +inline epiworld_double Model::par(std::string pname) const { - return parameters[pname]; + const auto iter = parameters.find(pname); + if (iter == parameters.end()) + throw std::logic_error("The parameter " + pname + " does not exists."); + return iter->second; } #define DURCAST(tunit,txtunit) {\ diff --git a/inst/include/epiworld/models/seirconnected.hpp b/inst/include/epiworld/models/seirconnected.hpp index cd87e6c3..296f2f3c 100644 --- a/inst/include/epiworld/models/seirconnected.hpp +++ b/inst/include/epiworld/models/seirconnected.hpp @@ -60,6 +60,16 @@ class ModelSEIRCONN : public epiworld::Model size_t get_n_infected() const { return infected.size(); } + /*** + * @brief Compute expected generation time + * @param max_days Maximum number of days. + * @param max_contacts Maximum number of contacts. + */ + std::vector< double > generation_time_expected( + int max_days = 200, + int max_contacts = 200 + ) const; + }; template @@ -388,4 +398,61 @@ inline ModelSEIRCONN & ModelSEIRCONN::initial_states( } +template +inline std::vector< double > ModelSEIRCONN::generation_time_expected( + int max_days, + int max_contacts +) const +{ + + // Retrieving total counts + std::vector< int > h_date; + std::vector< std::string > h_state; + std::vector< int > h_counts; + const auto this_const = dynamic_cast *>(this); + this_const->get_db().get_hist_total( + &h_date, + &h_state, + &h_counts + ); + + // Retrieving information on susceptibles + std::vector< double > S(this_const->get_ndays(), 0.0); + for (size_t i = 0; i < h_date.size(); ++i) + { + if (h_state[i] == "Susceptible") + S[h_date[i]] += h_counts[i]; + } + + // Computing the expected number of days in exposed + double days_exposed = this_const->par("Avg. Incubation days"); + + // The generation time in the SEIR model starts from 2, as agents + // spend at least one day in the exposed state, and 1 day in the + // infectious state before starting transmitting. + std::vector< double > gen_times( + this_const->get_ndays(), 1.0 + days_exposed + ); + + double p_c = this_const->par("Contact rate")/this_const->size(); + double p_i = this_const->par("Prob. Transmission"); + double p_r = this_const->par("Prob. Recovery"); + + for (size_t i = 0u; i < this_const->get_ndays(); ++i) + { + gen_times[i] += gen_int_mean( + S[i], + p_c, + p_i, + p_r, + max_days, + max_contacts + ); + + } + + return gen_times; + +} + #endif diff --git a/inst/include/epiworld/models/sirconnected.hpp b/inst/include/epiworld/models/sirconnected.hpp index c66984a1..df39bce4 100644 --- a/inst/include/epiworld/models/sirconnected.hpp +++ b/inst/include/epiworld/models/sirconnected.hpp @@ -66,6 +66,15 @@ class ModelSIRCONN : public epiworld::Model return infected.size(); } + /*** + * @brief Compute expected generation time + * @param max_days Maximum number of days. + * @param max_contacts Maximum number of contacts. + */ + std::vector< double > generation_time_expected( + int max_days = 200, + int max_contacts = 200 + ) const; }; @@ -361,5 +370,54 @@ inline ModelSIRCONN & ModelSIRCONN::initial_states( } +template +inline std::vector< double > ModelSIRCONN::generation_time_expected( + int max_days, + int max_contacts +) const +{ + + // Retrieving total counts + std::vector< int > h_date; + std::vector< std::string > h_state; + std::vector< int > h_counts; + const auto this_const = dynamic_cast *>(this); + this_const->get_db().get_hist_total( + &h_date, + &h_state, + &h_counts + ); + + // Retrieving information on susceptibles + std::vector< double > S(this_const->get_ndays(), 0.0); + for (size_t i = 0; i < h_date.size(); ++i) + { + if (h_state[i] == "Susceptible") + S[h_date[i]] += h_counts[i]; + } + + // The generation time in the SIR model starts from 1, as agents + // spend at least one day in the infected state before starting + // transmitting. + std::vector< double > gen_times(this_const->get_ndays(), 1.0); + double p_c = this_const->par("Contact rate")/this_const->size(); + double p_i = this_const->par("Transmission rate"); + double p_r = this_const->par("Recovery rate"); + for (size_t i = 0u; i < this_const->get_ndays(); ++i) + { + gen_times[i] = gen_int_mean( + S[i], + p_c, + p_i, + p_r, + max_days, + max_contacts + ); + + } + + return gen_times; + +} #endif diff --git a/inst/include/epiworld/models/surveillance.hpp b/inst/include/epiworld/models/surveillance.hpp index 6dca7e4e..8b1a2889 100644 --- a/inst/include/epiworld/models/surveillance.hpp +++ b/inst/include/epiworld/models/surveillance.hpp @@ -227,7 +227,7 @@ inline ModelSURV::ModelSURV( // How many will we find std::binomial_distribution<> bdist(m->size(), m->par("Surveilance prob.")); - int nsampled = bdist(m->get_rand_endgine()); + int nsampled = bdist(*m->get_rand_endgine()); int to_go = nsampled + 1; diff --git a/inst/include/epiworld/progress.hpp b/inst/include/epiworld/progress.hpp index a0cd001c..0cad6137 100644 --- a/inst/include/epiworld/progress.hpp +++ b/inst/include/epiworld/progress.hpp @@ -31,9 +31,16 @@ class Progress { inline Progress::Progress(int n_, int width_) { + if (n_ < 0) + throw std::invalid_argument("n must be greater or equal than 0."); + + if (width_ <= 0) + throw std::invalid_argument("width must be greater than 0"); + width = std::max(7, width_ - 7); n = n_; - step_size = static_cast(width)/static_cast(n); + step_size = n == 0? width : static_cast(width)/ + static_cast(n); last_loc = 0; i = 0; @@ -58,10 +65,9 @@ inline void Progress::next() { cur_loc = std::floor((++i) * step_size); - #ifndef EPI_DEBUG for (int j = 0; j < (cur_loc - last_loc); ++j) - { + { printf_epiworld("|"); } #endif diff --git a/inst/include/epiworld/random_graph.hpp b/inst/include/epiworld/random_graph.hpp index dfe6883d..af9f4a5d 100644 --- a/inst/include/epiworld/random_graph.hpp +++ b/inst/include/epiworld/random_graph.hpp @@ -14,7 +14,7 @@ class RandGraph { RandGraph(int N_) : N(N_) {}; void init(int s); - void set_rand_engine(std::mt19937 & e); + void set_rand_engine(std::shared_ptr< std::mt19937 > & e); epiworld_double runif(); }; @@ -35,10 +35,10 @@ inline void RandGraph::init(int s) { } -inline void RandGraph::set_rand_engine(std::mt19937 & e) +inline void RandGraph::set_rand_engine(std::shared_ptr< std::mt19937 > & e) { - engine = std::make_shared< std::mt19937 >(e); + engine = e; } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index c1ab43fd..ae890ec8 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -440,13 +440,6 @@ 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 @@ -1145,7 +1138,6 @@ 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 6c56186a..acb17680 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -255,16 +255,16 @@ SEXP set_kernel_fun_cpp( } // Rand Engine -[[cpp11::register]] -SEXP set_rand_engine_lfmcmc_cpp( - SEXP lfmcmc, - SEXP eng -) { - WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - cpp11::external_pointer eng_ptr(eng); - lfmcmc_ptr->set_rand_engine(*eng_ptr); - return lfmcmc; -} +// [[cpp11::register]] +// SEXP set_rand_engine_lfmcmc_cpp( +// SEXP lfmcmc, +// SEXP eng +// ) { +// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); +// cpp11::external_pointer eng_ptr(eng); +// lfmcmc_ptr->set_rand_engine(*eng_ptr); +// return lfmcmc; +// } // s should be of type epiworld_fast_uint [[cpp11::register]] diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 1300f2e1..58b63ab0 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -63,9 +63,9 @@ obs_data <- unname(as.integer(get_today_total(model_sir))) ```{r lfmcmc-setup} # Define Simulation Function simfun <- function(params, m) { - set_param(model_sir, "Recovery Rate", params[1]) - set_param(model_sir, "Transmission Rate", params[2]) - reset(model_sir) + set_param(model_sir, "Recovery rate", params[1]) + set_param(model_sir, "Transmission rate", params[2]) + run( model_sir, ndays = 50, From aa44003165c91b12e09b2c1635a6c631854db7c5 Mon Sep 17 00:00:00 2001 From: "George G. Vega Yon" Date: Tue, 29 Oct 2024 13:01:57 -0600 Subject: [PATCH 45/70] Getting closer --- inst/include/epiworld/random_graph.hpp | 7 ++----- src/lfmcmc.cpp | 4 ++-- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/inst/include/epiworld/random_graph.hpp b/inst/include/epiworld/random_graph.hpp index af9f4a5d..ee13b5f3 100644 --- a/inst/include/epiworld/random_graph.hpp +++ b/inst/include/epiworld/random_graph.hpp @@ -5,7 +5,7 @@ class RandGraph { private: std::shared_ptr< std::mt19937 > engine; - std::shared_ptr< std::uniform_real_distribution<> > unifd; + std::uniform_real_distribution<> unifd; int N = 0; bool initialized = false; @@ -27,9 +27,6 @@ inline void RandGraph::init(int s) { engine->seed(s); - if (!unifd) - unifd = std::make_shared< std::uniform_real_distribution<> >(0, 1); - initialized = true; @@ -47,7 +44,7 @@ inline epiworld_double RandGraph::runif() { if (!initialized) throw std::logic_error("The object has not been initialized"); - return (*unifd)(engine); + return unifd(*engine); } diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index acb17680..84b69613 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -414,7 +414,7 @@ SEXP use_proposal_norm_reflective_cpp( SEXP lfmcmc ) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_proposal_fun(make_proposal_norm_reflective(0.5, 0, 1)); + lfmcmc_ptr->set_proposal_fun(make_proposal_norm_reflective>(.5, 0, 1)); return lfmcmc; } @@ -423,7 +423,7 @@ SEXP use_kernel_fun_gaussian_cpp( SEXP lfmcmc ) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_kernel_fun(kernel_fun_gaussian); + lfmcmc_ptr->set_kernel_fun(kernel_fun_gaussian>); return lfmcmc; } From 30d985c5a6c8f9973475a3d9b40cddfbfeea6ead Mon Sep 17 00:00:00 2001 From: "George G. Vega Yon" Date: Tue, 29 Oct 2024 14:43:49 -0600 Subject: [PATCH 46/70] Updating epiworld --- inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp | 2 +- inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp | 2 +- src/lfmcmc.cpp | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp index 60a896f3..d8cb0580 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp @@ -206,7 +206,7 @@ class LFMCMC { * @param eng */ ///@{ - void set_rand_engine(std::shared_ptr< std::mt19937 > & eng); + void set_rand_engine(const std::shared_ptr< std::mt19937 > & eng); std::shared_ptr< std::mt19937 > & get_rand_endgine(); void seed(epiworld_fast_uint s); void set_rand_gamma(epiworld_double alpha, epiworld_double beta); diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp index 3984df2a..4df2f31c 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp @@ -378,7 +378,7 @@ inline void LFMCMC::seed(epiworld_fast_uint s) { } template -inline void LFMCMC::set_rand_engine(std::shared_ptr< std::mt19937 > & eng) +inline void LFMCMC::set_rand_engine(const std::shared_ptr< std::mt19937 > & eng) { engine = eng; } diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 84b69613..9e8d5e38 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -23,7 +23,8 @@ SEXP LFMCMC_cpp( new LFMCMC() ); - lfmcmc_ptr->set_rand_engine(cpp11::external_pointer>(model)->get_rand_endgine()); + cpp11::external_pointer> modelptr(model); + lfmcmc_ptr->set_rand_engine(modelptr->get_rand_endgine()); return lfmcmc_ptr; } From bfb0b49c2940139685834f491408d7ddaf4b9a6a Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Thu, 31 Oct 2024 09:33:23 -0600 Subject: [PATCH 47/70] Sync with latest version of epiworld --- inst/include/epiworld/math/distributions.hpp | 168 ++++++++++++++++++ .../epiworld/math/lfmcmc/lfmcmc-bones.hpp | 2 +- .../epiworld/math/lfmcmc/lfmcmc-meat.hpp | 2 +- 3 files changed, 170 insertions(+), 2 deletions(-) create mode 100644 inst/include/epiworld/math/distributions.hpp diff --git a/inst/include/epiworld/math/distributions.hpp b/inst/include/epiworld/math/distributions.hpp new file mode 100644 index 00000000..b32a012e --- /dev/null +++ b/inst/include/epiworld/math/distributions.hpp @@ -0,0 +1,168 @@ +#ifndef EPIWORLD_MATH_DISTRIBUTIONS_HPP +#define EPIWORLD_MATH_DISTRIBUTIONS_HPP + +// Implementing the factorial function +/** + * @brief Compute the log of the factorial + * + * @param n Number + * + * @return The log of the factorial + */ +inline double log_factorial(int n) +{ + if (n == 0) + return 0.0; + return std::log(static_cast(n)) + log_factorial(n-1); +} + +/** + * @brief Compute the Poisson probability + * + * @param k Number of events + * @param lambda Rate + * @param max_n Maximum number of events + * @param as_log Return the log of the probability + * + * @return The Poisson probability + */ +inline double dpois( + int k, + double lambda, + int max_n = 100, + bool as_log = false + ) +{ + + if (max_n < k) + throw std::runtime_error("max_n must be greater than k"); + + double res = k * std::log(lambda) - lambda - log_factorial( + std::min(k, max_n) + ); + + return as_log ? res : std::exp(res); +} + +/** + * @brief Compute the probability of the generation interval + * + * @details + * If `p_0_approx` is negative, it will be computed using the Poisson + * distribution. If `normalizing` is negative, it will be computed on the fly + * + * @param g Generation interval + * @param S Population size + * @param p_c Probability of contact + * @param p_i Probability of infection + * @param p_r Probability of recovery + * @param p_0_approx Approximation of the probability of not being infected + * @param normalizing Normalizing constant + * @param max_contacts Maximum number of contacts + * @param max_days Maximum number of days + * + * @return The probability of the generation interval + * + */ +inline double dgenint( + int g, + double S, + double p_c, + double p_i, + double p_r, + double & p_0_approx, + double & normalizing, + int max_contacts = 200, + int max_days = 200 + ) { + + if ((g < 1) || (g > max_days)) + return 0.0; + + if (p_0_approx < 0.0) + { + + p_0_approx = 0.0; + for (int i = 0; i < max_contacts; ++i) + { + + p_0_approx += std::exp( + dpois(i, S * p_c, max_contacts, true) + + std::log(1.0 - p_i) * static_cast(i) + ); + + } + } + + double g_dbl = static_cast(g); + + if (normalizing < 0.0) + { + + normalizing = 1.0; + double log1_p_r = std::log(1.0 - p_r); + double log_p_r = std::log(p_r); + double log_p_0_approx = std::log(p_0_approx); + for (int i = 1; i <= max_days; ++i) + { + + double i_dbl = static_cast(i); + + normalizing -= std::exp( + log1_p_r * (i_dbl - 1.0) + + log_p_r + + log_p_0_approx * (i_dbl - 1.0) + ); + } + + } + + + return std::exp( + std::log(1 - p_r) * (g_dbl)+ + std::log(p_0_approx) * (g_dbl - 1.0) + + std::log(1.0 - p_0_approx) - + std::log(normalizing) + ); + +} + +// Mean of the generation interval +/** + * @brief Compute the mean of the generation interval + * @param S Population size. + * @param p_c Probability of contact. + * @param p_i Probability of infection. + * @param p_r Probability of recovery. + * @param max_days Maximum number of days. + * @param max_n Maximum number of contacts. + * + * @return The mean of the generation interval + */ +inline double gen_int_mean( + double S, + double p_c, + double p_i, + double p_r, + int max_days = 200, + int max_n = 200 + ) { + + double mean = 0.0; + double p_0_approx = -1.0; + double normalizing = -1.0; + for (int i = 1; i < max_days; ++i) + { + mean += + static_cast(i) * + dgenint( + i, S, p_c, p_i, p_r, p_0_approx, normalizing, max_n, max_days + ); + + } + + return mean; + +} + +#endif \ No newline at end of file diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp index d8cb0580..60a896f3 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp @@ -206,7 +206,7 @@ class LFMCMC { * @param eng */ ///@{ - void set_rand_engine(const std::shared_ptr< std::mt19937 > & eng); + void set_rand_engine(std::shared_ptr< std::mt19937 > & eng); std::shared_ptr< std::mt19937 > & get_rand_endgine(); void seed(epiworld_fast_uint s); void set_rand_gamma(epiworld_double alpha, epiworld_double beta); diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp index 4df2f31c..3984df2a 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp @@ -378,7 +378,7 @@ inline void LFMCMC::seed(epiworld_fast_uint s) { } template -inline void LFMCMC::set_rand_engine(const std::shared_ptr< std::mt19937 > & eng) +inline void LFMCMC::set_rand_engine(std::shared_ptr< std::mt19937 > & eng) { engine = eng; } From f9724db0ddf6803423235466278598fed356b2a9 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Thu, 31 Oct 2024 09:34:00 -0600 Subject: [PATCH 48/70] Add dev option to Makefile to build and install without vignettes --- Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Makefile b/Makefile index a3000888..b82b6696 100644 --- a/Makefile +++ b/Makefile @@ -52,3 +52,7 @@ docs: checkv: build R CMD check --as-cran --use-valgrind epiworldR*.tar.gz + +dev: clean + R CMD build --no-build-vignettes . + R CMD INSTALL epiworldR_$(VERSION).tar.gz From 13a7b4dbc342d3c98718b941fc22480db415eed9 Mon Sep 17 00:00:00 2001 From: "George G. Vega Yon" Date: Thu, 31 Oct 2024 14:31:24 -0600 Subject: [PATCH 49/70] Now is running --- R/cpp11.R | 4 - epiworldR.Rproj | 1 + src/cpp11.cpp | 8 -- src/lfmcmc.cpp | 161 +++++------------------------ vignettes/likelihood-free-mcmc.Rmd | 20 ++-- 5 files changed, 41 insertions(+), 153 deletions(-) diff --git a/R/cpp11.R b/R/cpp11.R index eeb3e508..900c105f 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -248,10 +248,6 @@ set_kernel_fun_cpp <- function(lfmcmc, fun) { .Call(`_epiworldR_set_kernel_fun_cpp`, lfmcmc, fun) } -seed_lfmcmc_cpp <- function(lfmcmc, s) { - .Call(`_epiworldR_seed_lfmcmc_cpp`, lfmcmc, s) -} - set_par_names_cpp <- function(lfmcmc, names) { .Call(`_epiworldR_set_par_names_cpp`, lfmcmc, names) } diff --git a/epiworldR.Rproj b/epiworldR.Rproj index eaa6b818..d9f3f4e4 100644 --- a/epiworldR.Rproj +++ b/epiworldR.Rproj @@ -14,5 +14,6 @@ LaTeX: pdfLaTeX BuildType: Package PackageUseDevtools: Yes +PackageCleanBeforeInstall: No PackageInstallArgs: --no-multiarch --with-keep.source PackageRoxygenize: rd,collate,namespace diff --git a/src/cpp11.cpp b/src/cpp11.cpp index ae890ec8..a01102df 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -440,13 +440,6 @@ extern "C" SEXP _epiworldR_set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun) { 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 - return cpp11::as_sexp(seed_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(s))); - END_CPP11 -} -// lfmcmc.cpp SEXP set_par_names_cpp(SEXP lfmcmc, std::vector< std::string > names); extern "C" SEXP _epiworldR_set_par_names_cpp(SEXP lfmcmc, SEXP names) { BEGIN_CPP11 @@ -1110,7 +1103,6 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_run_cpp", (DL_FUNC) &_epiworldR_run_cpp, 3}, {"_epiworldR_run_lfmcmc_cpp", (DL_FUNC) &_epiworldR_run_lfmcmc_cpp, 4}, {"_epiworldR_run_multiple_cpp", (DL_FUNC) &_epiworldR_run_multiple_cpp, 8}, - {"_epiworldR_seed_lfmcmc_cpp", (DL_FUNC) &_epiworldR_seed_lfmcmc_cpp, 2}, {"_epiworldR_set_agents_data_cpp", (DL_FUNC) &_epiworldR_set_agents_data_cpp, 3}, {"_epiworldR_set_death_reduction_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_cpp, 2}, {"_epiworldR_set_death_reduction_fun_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_fun_cpp, 3}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 9e8d5e38..5a69dbdf 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -2,6 +2,7 @@ #include "cpp11/external_pointer.hpp" #include "cpp11/r_vector.hpp" #include "cpp11/sexp.hpp" +#include #include "epiworld-common.h" @@ -26,6 +27,9 @@ SEXP LFMCMC_cpp( cpp11::external_pointer> modelptr(model); lfmcmc_ptr->set_rand_engine(modelptr->get_rand_endgine()); + // std::cout << "Engine of model : " << modelptr->get_rand_endgine() << std::endl; + // std::cout << "Engine of lfmcmc: " << lfmcmc_ptr->get_rand_endgine() << std::endl; + return lfmcmc_ptr; } @@ -37,7 +41,9 @@ SEXP run_lfmcmc_cpp( epiworld_double epsilon_ ) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + Rprintf("Running LFMCMC\n"); lfmcmc_ptr->run(params_init_, n_samples_, epsilon_); + Rprintf("LFMCMC Finished\n"); return lfmcmc; } @@ -76,19 +82,7 @@ SEXP set_proposal_fun_cpp( cpp11::function fun ) { - LFMCMCProposalFun fun_call = [fun](std::vector< epiworld_double >& params_now,const std::vector< epiworld_double >& params_prev, LFMCMC* model) -> void { - WrapLFMCMC(model_ptr)(model); - fun(params_now, params_prev, model_ptr); - return; - }; - - WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - - // TODO: Uncomment if needed, delete otherwise - // cpp11::external_pointer> fun_ptr = create_LFMCMCProposalFun_cpp(fun); - // lfmcmc_ptr->set_proposal_fun(*fun_ptr); - - lfmcmc_ptr->set_proposal_fun(fun_call); + cpp11::stop("Un implemented"); return lfmcmc; } @@ -117,16 +111,16 @@ SEXP set_simulation_fun_cpp( cpp11::function fun ) { - LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { - WrapLFMCMC(model_ptr)(model); + LFMCMCSimFun fun_call = [fun]( + const std::vector& params, + LFMCMC* + ) -> TData_default { - // TODO: This was added because of a similar construct in actions.cpp 'globalevent_fun_cpp()' - // It doesn't appear to help at all, so might be removable - cpp11::sexp modelptrs(model_ptr); - modelptrs.attr("class") = "epiworld_lfmcmc"; + auto params_doubles = cpp11::doubles(params); - TData_default res = cpp11::as_cpp(cpp11::integers(fun(params, model_ptr))); - return res; + return cpp11::as_cpp( + cpp11::integers(fun(params_doubles, params_doubles)) + ); }; WrapLFMCMC(lfmcmc_ptr)(lfmcmc); @@ -165,13 +159,11 @@ SEXP set_summary_fun_cpp( cpp11::function fun ) { - LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { - WrapLFMCMC(model_ptr)(model); - - // TODO: This was added because of a similar construct in actions.cpp 'globalevent_fun_cpp()' - // It doesn't appear to help at all, so might be removable - cpp11::sexp modelptrs(model_ptr); - modelptrs.attr("class") = "epiworld_lfmcmc"; + LFMCMCSummaryFun fun_call = [fun]( + std::vector< epiworld_double >& res, + const TData_default& dat, + LFMCMC* + ) -> void { // TODO: This was added because the memory error seemed linked to the assignment of the 'res' vector // It comes from the example summary function in the main epiworld (C++) repo @@ -188,16 +180,15 @@ SEXP set_summary_fun_cpp( // I used integers instead because the errors I was seeing reminded me that 'fun()' as defined in the vignette // returns a vector ('dat') // Adding this code resolved the errors I was seeing, but other errors persist so it is possible it wasn't the root cause - auto res_1 = fun(dat, model_ptr); - auto res_2 = cpp11::integers(res_1); + auto dat_int = cpp11::integers(dat); + auto res_1 = cpp11::integers(fun(dat_int, dat_int)); // TODO: This is also taken from the example summary function in the main epiworld (C++) repo // I added it to see if it resolved some of the errors associated with 'res' and having the correct type ('double' instead of 'int') // Adding this code resolved some errors I was seeing, but other errors persist so it is possible it wasn't the root cause // This might need to be removed in favor of the '.assign()' operation below // Also, the size_t i < res_2.size() operation throws a warning at compile time, so if it stays, that should be fixed - for (size_t i = 0u; i < res_2.size(); ++i) - res[i] = static_cast< epiworld_double >(res_2[i]); + std::copy(res_1.begin(), res_1.end(), res.begin()); // res.assign(res_2.begin(), res_2.end()); @@ -238,19 +229,7 @@ SEXP set_kernel_fun_cpp( SEXP lfmcmc, cpp11::function fun ) { - LFMCMCKernelFun fun_call = [fun](const std::vector< epiworld_double >& stats_now, const std::vector< epiworld_double >& stats_obs, epiworld_double epsilon, LFMCMC* model) -> epiworld_double { - WrapLFMCMC(model_ptr)(model); - cpp11::external_pointer res(fun(stats_now, stats_obs, epsilon, model_ptr)); - return *res; - }; - - WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - - // TODO: Uncomment if needed, delete otherwise - // cpp11::external_pointer> fun_ptr = create_LFMCMCKernelFun_cpp(fun); - // lfmcmc_ptr->set_kernel_fun(*fun_ptr); - - lfmcmc_ptr->set_kernel_fun(fun_call); + cpp11::stop("Unimplemented"); return lfmcmc; } @@ -267,17 +246,6 @@ SEXP set_kernel_fun_cpp( // return lfmcmc; // } -// s should be of type epiworld_fast_uint -[[cpp11::register]] -SEXP seed_lfmcmc_cpp( - SEXP lfmcmc, - unsigned long long int s -) { - WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->seed(s); - return lfmcmc; -} - [[cpp11::register]] SEXP set_par_names_cpp( SEXP lfmcmc, @@ -307,84 +275,6 @@ SEXP print_lfmcmc_cpp( return lfmcmc; } -// Factory methods -inline LFMCMCProposalFun make_proposal_norm_reflective( - epiworld_double scale, - epiworld_double lb, - epiworld_double ub -) { - - LFMCMCProposalFun fun = - [scale,lb,ub]( - std::vector< epiworld_double >& params_now, - const std::vector< epiworld_double >& params_prev, - LFMCMC* m - ) { - - // Making the proposal - for (size_t p = 0u; p < m->get_n_parameters(); ++p) - params_now[p] = params_prev[p] + m->rnorm() * scale; - - // Checking boundaries - epiworld_double d = ub - lb; - int odd; - epiworld_double d_above, d_below; - for (auto & p : params_now) - { - - // Correcting if parameter goes above the upper bound - if (p > ub) - { - d_above = p - ub; - odd = static_cast(std::floor(d_above / d)) % 2; - d_above = d_above - std::floor(d_above / d) * d; - - p = (lb + d_above) * odd + - (ub - d_above) * (1 - odd); - - // Correcting if parameter goes below upper bound - } else if (p < lb) - { - d_below = lb - p; - int odd = static_cast(std::floor(d_below / d)) % 2; - d_below = d_below - std::floor(d_below / d) * d; - - p = (ub - d_below) * odd + - (lb + d_below) * (1 - odd); - } - - } - - #ifdef EPI_DEBUG - for (auto & p : params_now) - if (p < lb || p > ub) - throw std::range_error("The parameter is out of bounds."); - #endif - - - return; - - }; - - return fun; -} - -inline epiworld_double kernel_fun_gaussian( - const std::vector< epiworld_double >& stats_now, - const std::vector< epiworld_double >& stats_obs, - epiworld_double epsilon, - LFMCMC* m -) { - - epiworld_double ans = 0.0; - for (size_t p = 0u; p < m->get_n_parameters(); ++p) - ans += std::pow(stats_obs[p] - stats_now[p], 2.0); - - return std::exp( - -.5 * (ans/std::pow(1 + std::pow(epsilon, 2.0)/3.0, 2.0)) - ) / sqrt2pi() ; - -} [[cpp11::register]] SEXP make_proposal_norm_reflective_cpp( @@ -392,7 +282,8 @@ SEXP make_proposal_norm_reflective_cpp( epiworld_double lb, epiworld_double ub ) { - LFMCMCProposalFun propfun = make_proposal_norm_reflective(scale, lb, ub); + LFMCMCProposalFun propfun = + make_proposal_norm_reflective(scale, lb, ub); return cpp11::external_pointer>( new LFMCMCProposalFun(propfun) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 58b63ab0..400b4866 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -51,7 +51,7 @@ run( seed = model_seed ) -print(model_sir) +summary(model_sir) ``` ## Extract Observed data @@ -63,14 +63,22 @@ obs_data <- unname(as.integer(get_today_total(model_sir))) ```{r lfmcmc-setup} # Define Simulation Function simfun <- function(params, m) { + set_param(model_sir, "Recovery rate", params[1]) set_param(model_sir, "Transmission rate", params[2]) run( model_sir, - ndays = 50, - seed = model_seed + ndays = 50 ) + + # if (i %% 10 == 0) { + # print(model_sir) + # } + + # if (i %% 100 == 0) { + # stop("Debugging!") + # } res <- unname(as.integer(get_today_total(model_sir))) return(res) } @@ -94,7 +102,7 @@ lfmcmc_model <- LFMCMC(model_sir) |> ## Set LFMCMC params ```{r lfmcmc-params} # Set initial parameters -par0 <- as.double(c(0.5, 0.5)) +par0 <- as.double(c(0.1, 0.5)) n_samp <- 2000 epsil <- as.double(1.0) ``` @@ -108,8 +116,8 @@ run_lfmcmc( epsilon_ = epsil ) -# set_stats_names(lfmcmc_model, get_states(model_sir)) -# set_par_names(lfmcmc_model, c("Immune recovery", "Infectiousness")) +set_stats_names(lfmcmc_model, get_states(model_sir)) +set_par_names(lfmcmc_model, c("Immune recovery", "Infectiousness")) print(lfmcmc_model) ``` From 01e370dc4babfb7064a5ed923912ac045f078ee2 Mon Sep 17 00:00:00 2001 From: "George G. Vega Yon" Date: Thu, 31 Oct 2024 14:33:25 -0600 Subject: [PATCH 50/70] Changing param --- vignettes/likelihood-free-mcmc.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 400b4866..f1e88020 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -31,7 +31,7 @@ model_seed <- 122 model_sir <- ModelSIR( name = "COVID-19", prevalence = .1, - transmission_rate = .1, + transmission_rate = .9, recovery_rate = .3 ) From 0ec462855b0f8351296f7c7ff644f04d9d7fe889 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Thu, 31 Oct 2024 15:53:43 -0600 Subject: [PATCH 51/70] Clean up Makefile --- Makefile | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index b82b6696..4dfbef48 100644 --- a/Makefile +++ b/Makefile @@ -48,11 +48,12 @@ clean: docs: Rscript --vanilla -e 'roxygen2::roxygenize()' -.PHONY: build update check clean docs docker-debug - 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 From 5d8930fadb12a95f0bf106c73c6e4d17db9369d5 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Thu, 31 Oct 2024 16:02:17 -0600 Subject: [PATCH 52/70] Clean up comments and unneed function --- NAMESPACE | 4 - R/LFMCMC.R | 30 ----- R/cpp11.R | 24 ++-- man/LFMCMC.Rd | 23 ---- src/cpp11.cpp | 44 +++---- src/lfmcmc.cpp | 180 ++++------------------------- vignettes/likelihood-free-mcmc.Rmd | 7 -- 7 files changed, 43 insertions(+), 269 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 47d7f986..ad21b0d0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -83,7 +83,6 @@ 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) @@ -169,8 +168,6 @@ export(has_tool) export(has_virus) export(initial_states) export(load_agents_entities_ties) -export(make_kernel_fun_gaussian_lfmcmc) -export(make_proposal_norm_reflective_lfmcmc) export(make_saver) export(plot_generation_time) export(plot_incidence) @@ -212,7 +209,6 @@ 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 2220b6dd..55a0b213 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -102,19 +102,6 @@ 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 @@ -164,23 +151,6 @@ print.epiworld_lfmcmc <- function(x, ...) { invisible(x) } -#' @rdname LFMCMC -#' @param scale Scale of the normal kernel -#' @param lb Lower bound (applies the same to all parameters) -#' @param ub Upper bound (applies the same to all parameters) -#' @returns The norm reflective LFMCMC proposal function -#' @export -make_proposal_norm_reflective_lfmcmc <- function(scale, lb, ub) { - invisible(make_proposal_norm_reflective_cpp(scale, lb, ub)) -} - -#' @rdname LFMCMC -#' @returns The gaussian LFMCMC kernel function -#' @export -make_kernel_fun_gaussian_lfmcmc <- function() { - invisible(make_kernel_fun_gaussian_cpp()) -} - #' @rdname LFMCMC #' @param lfmcmc The LFMCMC model #' @returns The LFMCMC model with proposal function set to norm reflective diff --git a/R/cpp11.R b/R/cpp11.R index 900c105f..b0e2fa1b 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -236,6 +236,10 @@ 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) } @@ -248,6 +252,10 @@ 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) } @@ -260,22 +268,6 @@ print_lfmcmc_cpp <- function(lfmcmc) { .Call(`_epiworldR_print_lfmcmc_cpp`, lfmcmc) } -make_proposal_norm_reflective_cpp <- function(scale, lb, ub) { - .Call(`_epiworldR_make_proposal_norm_reflective_cpp`, scale, lb, ub) -} - -make_kernel_fun_gaussian_cpp <- function() { - .Call(`_epiworldR_make_kernel_fun_gaussian_cpp`) -} - -use_proposal_norm_reflective_cpp <- function(lfmcmc) { - .Call(`_epiworldR_use_proposal_norm_reflective_cpp`, lfmcmc) -} - -use_kernel_fun_gaussian_cpp <- function(lfmcmc) { - .Call(`_epiworldR_use_kernel_fun_gaussian_cpp`, lfmcmc) -} - print_cpp <- function(m, lite) { .Call(`_epiworldR_print_cpp`, m, lite) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 29dc58ff..4913f042 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -9,13 +9,10 @@ \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} -\alias{make_proposal_norm_reflective_lfmcmc} -\alias{make_kernel_fun_gaussian_lfmcmc} \alias{use_proposal_norm_reflective} \alias{use_kernel_fun_gaussian} \title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} @@ -34,8 +31,6 @@ 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) @@ -44,10 +39,6 @@ set_stats_names(lfmcmc, names) \method{print}{epiworld_lfmcmc}(x, ...) -make_proposal_norm_reflective_lfmcmc(scale, lb, ub) - -make_kernel_fun_gaussian_lfmcmc() - use_proposal_norm_reflective(lfmcmc) use_kernel_fun_gaussian(lfmcmc) @@ -67,8 +58,6 @@ use_kernel_fun_gaussian(lfmcmc) \item{fun}{The LFMCMC kernel function} -\item{eng}{The rand engine} - \item{s}{The rand engine seed} \item{names}{The model stats names} @@ -76,12 +65,6 @@ use_kernel_fun_gaussian(lfmcmc) \item{x}{LFMCMC model to print} \item{...}{Ignored} - -\item{scale}{Scale of the normal kernel} - -\item{lb}{Lower bound (applies the same to all parameters)} - -\item{ub}{Upper bound (applies the same to all parameters)} } \value{ \itemize{ @@ -100,8 +83,6 @@ 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 @@ -110,10 +91,6 @@ The lfmcmc model with the stats names added The lfmcmc model -The norm reflective LFMCMC proposal function - -The gaussian LFMCMC kernel function - The LFMCMC model with proposal function set to norm reflective The LFMCMC model with kernel function set to gaussian diff --git a/src/cpp11.cpp b/src/cpp11.cpp index a01102df..42c1fb83 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -419,6 +419,13 @@ extern "C" SEXP _epiworldR_set_proposal_fun_cpp(SEXP lfmcmc, SEXP fun) { END_CPP11 } // lfmcmc.cpp +SEXP use_proposal_norm_reflective_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_use_proposal_norm_reflective_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(use_proposal_norm_reflective_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp SEXP set_simulation_fun_cpp(SEXP lfmcmc, cpp11::function fun); extern "C" SEXP _epiworldR_set_simulation_fun_cpp(SEXP lfmcmc, SEXP fun) { BEGIN_CPP11 @@ -440,6 +447,13 @@ extern "C" SEXP _epiworldR_set_kernel_fun_cpp(SEXP lfmcmc, SEXP fun) { END_CPP11 } // lfmcmc.cpp +SEXP use_kernel_fun_gaussian_cpp(SEXP lfmcmc); +extern "C" SEXP _epiworldR_use_kernel_fun_gaussian_cpp(SEXP lfmcmc) { + BEGIN_CPP11 + return cpp11::as_sexp(use_kernel_fun_gaussian_cpp(cpp11::as_cpp>(lfmcmc))); + END_CPP11 +} +// lfmcmc.cpp SEXP set_par_names_cpp(SEXP lfmcmc, std::vector< std::string > names); extern "C" SEXP _epiworldR_set_par_names_cpp(SEXP lfmcmc, SEXP names) { BEGIN_CPP11 @@ -460,34 +474,6 @@ extern "C" SEXP _epiworldR_print_lfmcmc_cpp(SEXP lfmcmc) { return cpp11::as_sexp(print_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc))); END_CPP11 } -// lfmcmc.cpp -SEXP make_proposal_norm_reflective_cpp(epiworld_double scale, epiworld_double lb, epiworld_double ub); -extern "C" SEXP _epiworldR_make_proposal_norm_reflective_cpp(SEXP scale, SEXP lb, SEXP ub) { - BEGIN_CPP11 - return cpp11::as_sexp(make_proposal_norm_reflective_cpp(cpp11::as_cpp>(scale), cpp11::as_cpp>(lb), cpp11::as_cpp>(ub))); - END_CPP11 -} -// lfmcmc.cpp -SEXP make_kernel_fun_gaussian_cpp(); -extern "C" SEXP _epiworldR_make_kernel_fun_gaussian_cpp() { - BEGIN_CPP11 - return cpp11::as_sexp(make_kernel_fun_gaussian_cpp()); - END_CPP11 -} -// lfmcmc.cpp -SEXP use_proposal_norm_reflective_cpp(SEXP lfmcmc); -extern "C" SEXP _epiworldR_use_proposal_norm_reflective_cpp(SEXP lfmcmc) { - BEGIN_CPP11 - return cpp11::as_sexp(use_proposal_norm_reflective_cpp(cpp11::as_cpp>(lfmcmc))); - END_CPP11 -} -// lfmcmc.cpp -SEXP use_kernel_fun_gaussian_cpp(SEXP lfmcmc); -extern "C" SEXP _epiworldR_use_kernel_fun_gaussian_cpp(SEXP lfmcmc) { - BEGIN_CPP11 - return cpp11::as_sexp(use_kernel_fun_gaussian_cpp(cpp11::as_cpp>(lfmcmc))); - END_CPP11 -} // model.cpp SEXP print_cpp(SEXP m, bool lite); extern "C" SEXP _epiworldR_print_cpp(SEXP m, SEXP lite) { @@ -1083,8 +1069,6 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_has_virus_cpp", (DL_FUNC) &_epiworldR_has_virus_cpp, 2}, {"_epiworldR_initial_states_cpp", (DL_FUNC) &_epiworldR_initial_states_cpp, 2}, {"_epiworldR_load_agents_entities_ties_cpp", (DL_FUNC) &_epiworldR_load_agents_entities_ties_cpp, 3}, - {"_epiworldR_make_kernel_fun_gaussian_cpp", (DL_FUNC) &_epiworldR_make_kernel_fun_gaussian_cpp, 0}, - {"_epiworldR_make_proposal_norm_reflective_cpp", (DL_FUNC) &_epiworldR_make_proposal_norm_reflective_cpp, 3}, {"_epiworldR_make_saver_cpp", (DL_FUNC) &_epiworldR_make_saver_cpp, 10}, {"_epiworldR_print_agent_cpp", (DL_FUNC) &_epiworldR_print_agent_cpp, 3}, {"_epiworldR_print_agent_tools_cpp", (DL_FUNC) &_epiworldR_print_agent_tools_cpp, 1}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 5a69dbdf..2c9130b4 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -27,9 +27,6 @@ SEXP LFMCMC_cpp( cpp11::external_pointer> modelptr(model); lfmcmc_ptr->set_rand_engine(modelptr->get_rand_endgine()); - // std::cout << "Engine of model : " << modelptr->get_rand_endgine() << std::endl; - // std::cout << "Engine of lfmcmc: " << lfmcmc_ptr->get_rand_endgine() << std::endl; - return lfmcmc_ptr; } @@ -58,24 +55,6 @@ SEXP set_observed_data_cpp( return lfmcmc; } -// TODO: Uncomment if needed, delete otherwise -// LFMCMC Proposal Function -// [[cpp11::register]] -// SEXP create_LFMCMCProposalFun_cpp( -// cpp11::function fun -// ) { - -// LFMCMCProposalFun fun_call = [fun](std::vector< epiworld_double >& params_now,const std::vector< epiworld_double >& params_prev, LFMCMC* model) -> void { -// WrapLFMCMC(lfmcmc_ptr)(model); -// fun(params_now, params_prev, lfmcmc_ptr); -// return; -// }; - -// return cpp11::external_pointer>( -// new LFMCMCProposalFun(fun_call) -// ); -// } - [[cpp11::register]] SEXP set_proposal_fun_cpp( SEXP lfmcmc, @@ -87,23 +66,15 @@ SEXP set_proposal_fun_cpp( return lfmcmc; } -// TODO: Uncomment if needed, delete otherwise -// LFMCMC Simulation Function -// [[cpp11::register]] -// SEXP create_LFMCMCSimFun_cpp( -// cpp11::function fun -// ) { - -// LFMCMCSimFun fun_call = [fun](const std::vector& params, LFMCMC* model) -> TData_default { -// WrapLFMCMC(lfmcmc_ptr)(model); -// TData_default res = cpp11::as_cpp(cpp11::integers(fun(params, lfmcmc_ptr))); -// return res; -// }; - -// return cpp11::external_pointer>( -// new LFMCMCSimFun(fun_call) -// ); -// } +// Use proposal function defined in epiworld +[[cpp11::register]] +SEXP use_proposal_norm_reflective_cpp( + SEXP lfmcmc +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_proposal_fun(make_proposal_norm_reflective>(.5, 0, 1)); + return lfmcmc; +} [[cpp11::register]] SEXP set_simulation_fun_cpp( @@ -125,34 +96,11 @@ SEXP set_simulation_fun_cpp( WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - // TODO: Uncomment if needed, delete otherwise - // cpp11::external_pointer> fun_ptr = create_LFMCMCSimFun_cpp(fun); - // lfmcmc_ptr->set_simulation_fun(*fun_ptr); - lfmcmc_ptr->set_simulation_fun(fun_call); return lfmcmc; } -// TODO: Uncomment if needed, delete otherwise -// LFMCMC Summary Function -// [[cpp11::register]] -// SEXP create_LFMCMCSummaryFun_cpp( -// cpp11::function fun -// ) { - -// LFMCMCSummaryFun fun_call = [fun](std::vector< epiworld_double >& res, const TData_default& dat, LFMCMC* model) -> void { -// WrapLFMCMC(lfmcmc_ptr)(model); -// auto res_tmp = cpp11::as_cpp>(cpp11::doubles(fun(dat, lfmcmc_ptr))); -// res.assign(res_tmp.begin(), res_tmp.end()); -// return; -// }; - -// return cpp11::external_pointer>( -// new LFMCMCSummaryFun(fun_call) -// ); -// } - [[cpp11::register]] SEXP set_summary_fun_cpp( SEXP lfmcmc, @@ -165,65 +113,25 @@ SEXP set_summary_fun_cpp( LFMCMC* ) -> void { - // TODO: This was added because the memory error seemed linked to the assignment of the 'res' vector - // It comes from the example summary function in the main epiworld (C++) repo - // The .resize() appears to still throw an error in valgrind - // This might need to be removed + // TODO: Check if this is necessary if (res.size() == 0u) res.resize(dat.size()); - // auto res_1 = fun(dat, model_ptr); - // auto res_2 = cpp11::doubles(res_1); - // auto res_tmp = cpp11::as_cpp>(res_2); - - // TODO: Originally, this code was all one line and used 'cpp11::doubles' instead of 'cpp11::integers' - // I used integers instead because the errors I was seeing reminded me that 'fun()' as defined in the vignette - // returns a vector ('dat') - // Adding this code resolved the errors I was seeing, but other errors persist so it is possible it wasn't the root cause auto dat_int = cpp11::integers(dat); - auto res_1 = cpp11::integers(fun(dat_int, dat_int)); - - // TODO: This is also taken from the example summary function in the main epiworld (C++) repo - // I added it to see if it resolved some of the errors associated with 'res' and having the correct type ('double' instead of 'int') - // Adding this code resolved some errors I was seeing, but other errors persist so it is possible it wasn't the root cause - // This might need to be removed in favor of the '.assign()' operation below - // Also, the size_t i < res_2.size() operation throws a warning at compile time, so if it stays, that should be fixed - std::copy(res_1.begin(), res_1.end(), res.begin()); + auto res_tmp = cpp11::integers(fun(dat_int, dat_int)); - // res.assign(res_2.begin(), res_2.end()); + std::copy(res_tmp.begin(), res_tmp.end(), res.begin()); return; }; WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - // TODO: Uncomment if needed, delete otherwise - // cpp11::external_pointer> fun_ptr = create_LFMCMCSummaryFun_cpp(fun); - // lfmcmc_ptr->set_summary_fun(*fun_ptr); - lfmcmc_ptr->set_summary_fun(fun_call); return lfmcmc; } -// TODO: Uncomment if needed, delete otherwise -// LFMCMC Kernel Function -// [[cpp11::register]] -// SEXP create_LFMCMCKernelFun_cpp( -// cpp11::function fun -// ) { - -// LFMCMCKernelFun fun_call = [fun](const std::vector< epiworld_double >& stats_now, const std::vector< epiworld_double >& stats_obs, epiworld_double epsilon, LFMCMC* model) -> epiworld_double { -// WrapLFMCMC(lfmcmc_ptr)(model); -// cpp11::external_pointer res(fun(stats_now, stats_obs, epsilon, lfmcmc_ptr)); -// return *res; -// }; - -// return cpp11::external_pointer>( -// new LFMCMCKernelFun(fun_call) -// ); -// } - [[cpp11::register]] SEXP set_kernel_fun_cpp( SEXP lfmcmc, @@ -234,17 +142,15 @@ SEXP set_kernel_fun_cpp( return lfmcmc; } -// Rand Engine -// [[cpp11::register]] -// SEXP set_rand_engine_lfmcmc_cpp( -// SEXP lfmcmc, -// SEXP eng -// ) { -// WrapLFMCMC(lfmcmc_ptr)(lfmcmc); -// cpp11::external_pointer eng_ptr(eng); -// lfmcmc_ptr->set_rand_engine(*eng_ptr); -// return lfmcmc; -// } +// Use kernel function defined in epiworld +[[cpp11::register]] +SEXP use_kernel_fun_gaussian_cpp( + SEXP lfmcmc +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->set_kernel_fun(kernel_fun_gaussian>); + return lfmcmc; +} [[cpp11::register]] SEXP set_par_names_cpp( @@ -275,48 +181,4 @@ SEXP print_lfmcmc_cpp( return lfmcmc; } - -[[cpp11::register]] -SEXP make_proposal_norm_reflective_cpp( - epiworld_double scale, - epiworld_double lb, - epiworld_double ub -) { - LFMCMCProposalFun propfun = - make_proposal_norm_reflective(scale, lb, ub); - - return cpp11::external_pointer>( - new LFMCMCProposalFun(propfun) - ); -} - -[[cpp11::register]] -SEXP make_kernel_fun_gaussian_cpp() { - - LFMCMCKernelFun kernelfun = kernel_fun_gaussian; - - return cpp11::external_pointer>( - new LFMCMCKernelFun(kernelfun) - ); -} - -// Testing functions -[[cpp11::register]] -SEXP use_proposal_norm_reflective_cpp( - SEXP lfmcmc -) { - WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_proposal_fun(make_proposal_norm_reflective>(.5, 0, 1)); - return lfmcmc; -} - -[[cpp11::register]] -SEXP use_kernel_fun_gaussian_cpp( - SEXP lfmcmc -) { - WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->set_kernel_fun(kernel_fun_gaussian>); - return lfmcmc; -} - #undef WrapLFMCMC diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index f1e88020..cb42902c 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -72,13 +72,6 @@ simfun <- function(params, m) { ndays = 50 ) - # if (i %% 10 == 0) { - # print(model_sir) - # } - - # if (i %% 100 == 0) { - # stop("Debugging!") - # } res <- unname(as.integer(get_today_total(model_sir))) return(res) } From 71e6fc1bba44de0869e53dac1c30b950542c32b8 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 08:21:59 -0700 Subject: [PATCH 53/70] Clean up LFMCMC vignette --- vignettes/likelihood-free-mcmc.Rmd | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index cb42902c..613a9ab2 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -19,10 +19,11 @@ knitr::opts_chunk$set( # Introduction The purpose of the "lfmcmc" function is to perform a Likelihood-Free Markhov Chain Monte Carlo simulation. -# Example: Using LFMCMC to calibrate SIR Model +# Example: Using LFMCMC to calibrate an SIR Model -## Setup and Running Model +## Setup and Running the Model Create an SIR Model and add a small world population. +Then, run the model. ```{r sir-setup} library(epiworldR) @@ -54,14 +55,12 @@ run( summary(model_sir) ``` -## Extract Observed data -```{r extract-obs-data} +## Setup LFMCMC +```{r lfmcmc-setup} +# Extract the observed data from the model obs_data <- unname(as.integer(get_today_total(model_sir))) -``` -## Setup LFMCMC Functions -```{r lfmcmc-setup} -# Define Simulation Function +# Define the LFMCMC simulation function simfun <- function(params, m) { set_param(model_sir, "Recovery rate", params[1]) @@ -76,14 +75,12 @@ simfun <- function(params, m) { return(res) } -# Define Summary Function +# Define the LFMCMC summary function sumfun <- function(dat, m) { return(dat) } -``` -## Init LFMCMC -```{r lfmcmc-init} +# Create the LFMCMC model using a norm reflective proposal function and a Gaussian kernel function lfmcmc_model <- LFMCMC(model_sir) |> set_simulation_fun(simfun) |> set_summary_fun(sumfun) |> @@ -92,16 +89,14 @@ lfmcmc_model <- LFMCMC(model_sir) |> set_observed_data(obs_data) ``` -## Set LFMCMC params -```{r lfmcmc-params} +## Run LFMCMC simulation +```{r lfmcmc-run} # Set initial parameters par0 <- as.double(c(0.1, 0.5)) n_samp <- 2000 epsil <- as.double(1.0) -``` -## Run LFMCMC -```{r lfmcmc-run} +# Run the LFMCMC simulation run_lfmcmc( lfmcmc = lfmcmc_model, params_init_ = par0, @@ -109,6 +104,7 @@ run_lfmcmc( epsilon_ = epsil ) +# Print the results set_stats_names(lfmcmc_model, get_states(model_sir)) set_par_names(lfmcmc_model, c("Immune recovery", "Infectiousness")) From 2d0571c05412ac470246c6972e476fd16a882afe Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 08:28:28 -0700 Subject: [PATCH 54/70] Remove second parameter in R version of simulation and summary functions --- src/lfmcmc.cpp | 6 ++---- vignettes/likelihood-free-mcmc.Rmd | 4 ++-- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 2c9130b4..d7f89ab5 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -38,9 +38,7 @@ SEXP run_lfmcmc_cpp( epiworld_double epsilon_ ) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - Rprintf("Running LFMCMC\n"); lfmcmc_ptr->run(params_init_, n_samples_, epsilon_); - Rprintf("LFMCMC Finished\n"); return lfmcmc; } @@ -90,7 +88,7 @@ SEXP set_simulation_fun_cpp( auto params_doubles = cpp11::doubles(params); return cpp11::as_cpp( - cpp11::integers(fun(params_doubles, params_doubles)) + cpp11::integers(fun(params_doubles)) ); }; @@ -118,7 +116,7 @@ SEXP set_summary_fun_cpp( res.resize(dat.size()); auto dat_int = cpp11::integers(dat); - auto res_tmp = cpp11::integers(fun(dat_int, dat_int)); + auto res_tmp = cpp11::integers(fun(dat_int)); std::copy(res_tmp.begin(), res_tmp.end(), res.begin()); diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 613a9ab2..8f61a654 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -61,7 +61,7 @@ summary(model_sir) obs_data <- unname(as.integer(get_today_total(model_sir))) # Define the LFMCMC simulation function -simfun <- function(params, m) { +simfun <- function(params) { set_param(model_sir, "Recovery rate", params[1]) set_param(model_sir, "Transmission rate", params[2]) @@ -76,7 +76,7 @@ simfun <- function(params, m) { } # Define the LFMCMC summary function -sumfun <- function(dat, m) { +sumfun <- function(dat) { return(dat) } From ad0cda04ee06728d096515f0c46dec060245b775 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 08:32:48 -0700 Subject: [PATCH 55/70] Restore seed_lfmcmc_cpp() --- R/cpp11.R | 4 ++++ src/cpp11.cpp | 8 ++++++++ src/lfmcmc.cpp | 10 ++++++++++ vignettes/likelihood-free-mcmc.Rmd | 3 ++- 4 files changed, 24 insertions(+), 1 deletion(-) diff --git a/R/cpp11.R b/R/cpp11.R index b0e2fa1b..9b2a4141 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -256,6 +256,10 @@ use_kernel_fun_gaussian_cpp <- function(lfmcmc) { .Call(`_epiworldR_use_kernel_fun_gaussian_cpp`, lfmcmc) } +seed_lfmcmc_cpp <- function(lfmcmc, s) { + .Call(`_epiworldR_seed_lfmcmc_cpp`, lfmcmc, s) +} + set_par_names_cpp <- function(lfmcmc, names) { .Call(`_epiworldR_set_par_names_cpp`, lfmcmc, names) } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 42c1fb83..e7662ef0 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -454,6 +454,13 @@ extern "C" SEXP _epiworldR_use_kernel_fun_gaussian_cpp(SEXP lfmcmc) { 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 + return cpp11::as_sexp(seed_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(s))); + END_CPP11 +} +// lfmcmc.cpp SEXP set_par_names_cpp(SEXP lfmcmc, std::vector< std::string > names); extern "C" SEXP _epiworldR_set_par_names_cpp(SEXP lfmcmc, SEXP names) { BEGIN_CPP11 @@ -1087,6 +1094,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_run_cpp", (DL_FUNC) &_epiworldR_run_cpp, 3}, {"_epiworldR_run_lfmcmc_cpp", (DL_FUNC) &_epiworldR_run_lfmcmc_cpp, 4}, {"_epiworldR_run_multiple_cpp", (DL_FUNC) &_epiworldR_run_multiple_cpp, 8}, + {"_epiworldR_seed_lfmcmc_cpp", (DL_FUNC) &_epiworldR_seed_lfmcmc_cpp, 2}, {"_epiworldR_set_agents_data_cpp", (DL_FUNC) &_epiworldR_set_agents_data_cpp, 3}, {"_epiworldR_set_death_reduction_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_cpp, 2}, {"_epiworldR_set_death_reduction_fun_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_fun_cpp, 3}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index d7f89ab5..6668a5e2 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -150,6 +150,16 @@ SEXP use_kernel_fun_gaussian_cpp( return lfmcmc; } +[[cpp11::register]] +SEXP seed_lfmcmc_cpp( + SEXP lfmcmc, + unsigned long long int s +) { + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + lfmcmc_ptr->seed(s); + return lfmcmc; +} + [[cpp11::register]] SEXP set_par_names_cpp( SEXP lfmcmc, diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 8f61a654..04d0dd49 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -86,7 +86,8 @@ lfmcmc_model <- LFMCMC(model_sir) |> set_summary_fun(sumfun) |> use_proposal_norm_reflective() |> use_kernel_fun_gaussian() |> - set_observed_data(obs_data) + set_observed_data(obs_data) |> + seed_lfmcmc(model_seed) ``` ## Run LFMCMC simulation From dfb68279b36b8b011e489d106f818acda67c8ad9 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 09:37:57 -0700 Subject: [PATCH 56/70] Cleaning up files --- src/lfmcmc.cpp | 1 - vignettes/likelihood-free-mcmc.Rmd | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 6668a5e2..6dcd6d81 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -111,7 +111,6 @@ SEXP set_summary_fun_cpp( LFMCMC* ) -> void { - // TODO: Check if this is necessary if (res.size() == 0u) res.resize(dat.size()); diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 04d0dd49..8f61a654 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -86,8 +86,7 @@ lfmcmc_model <- LFMCMC(model_sir) |> set_summary_fun(sumfun) |> use_proposal_norm_reflective() |> use_kernel_fun_gaussian() |> - set_observed_data(obs_data) |> - seed_lfmcmc(model_seed) + set_observed_data(obs_data) ``` ## Run LFMCMC simulation From cba14eae3f5db3026cb526f559f7cdc5035408c6 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 10:49:33 -0700 Subject: [PATCH 57/70] Sync with C++ epiworld library --- inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp | 3 ++- inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp | 6 +++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp index 60a896f3..7002aa24 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-bones.hpp @@ -187,7 +187,8 @@ class LFMCMC { void run( std::vector< epiworld_double > param_init, size_t n_samples_, - epiworld_double epsilon_ + epiworld_double epsilon_, + int seed = -1 ); LFMCMC() {}; diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp index 3984df2a..c7565121 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat.hpp @@ -205,7 +205,8 @@ template inline void LFMCMC::run( std::vector< epiworld_double > params_init_, size_t n_samples_, - epiworld_double epsilon_ + epiworld_double epsilon_, + int seed ) { @@ -218,6 +219,9 @@ inline void LFMCMC::run( params_init = params_init_; n_parameters = params_init_.size(); + if (seed >= 0) + this->seed(seed); + params_now.resize(n_parameters); params_prev.resize(n_parameters); From 9ae85f975ccb586c3129d0e3e61fad1e80eca641 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 10:50:48 -0700 Subject: [PATCH 58/70] Remove seed_lfmcmc --- NAMESPACE | 2 -- R/LFMCMC.R | 13 ------------- R/cpp11.R | 4 ---- man/LFMCMC.Rd | 7 ------- src/cpp11.cpp | 8 -------- src/lfmcmc.cpp | 10 ---------- 6 files changed, 44 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ad21b0d0..316e5938 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -76,7 +76,6 @@ S3method(queuing_on,epiworld_sirconn) S3method(run,epiworld_model) S3method(run_lfmcmc,epiworld_lfmcmc) S3method(run_multiple,epiworld_model) -S3method(seed_lfmcmc,epiworld_lfmcmc) S3method(set_kernel_fun,epiworld_lfmcmc) S3method(set_name,epiworld_model) S3method(set_observed_data,epiworld_lfmcmc) @@ -181,7 +180,6 @@ export(run) export(run_lfmcmc) export(run_multiple) export(run_multiple_get_results) -export(seed_lfmcmc) export(set_agents_data) export(set_death_reduction) export(set_death_reduction_fun) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 55a0b213..05b573e7 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -102,19 +102,6 @@ set_kernel_fun.epiworld_lfmcmc <- function(lfmcmc, fun) { invisible(lfmcmc) } -#' @rdname LFMCMC -#' @param lfmcmc LFMCMC model -#' @param s The rand engine seed -#' @returns The lfmcmc model with the seed set -#' @export -seed_lfmcmc <- function(lfmcmc, s) UseMethod("seed_lfmcmc") - -#' @export -seed_lfmcmc.epiworld_lfmcmc <- function(lfmcmc, s) { - seed_lfmcmc_cpp(lfmcmc, s) - invisible(lfmcmc) -} - #' @rdname LFMCMC #' @param lfmcmc LFMCMC model #' @param names The model parameter names diff --git a/R/cpp11.R b/R/cpp11.R index 9b2a4141..b0e2fa1b 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -256,10 +256,6 @@ use_kernel_fun_gaussian_cpp <- function(lfmcmc) { .Call(`_epiworldR_use_kernel_fun_gaussian_cpp`, lfmcmc) } -seed_lfmcmc_cpp <- function(lfmcmc, s) { - .Call(`_epiworldR_seed_lfmcmc_cpp`, lfmcmc, s) -} - set_par_names_cpp <- function(lfmcmc, names) { .Call(`_epiworldR_set_par_names_cpp`, lfmcmc, names) } diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 4913f042..558368e4 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -9,7 +9,6 @@ \alias{set_simulation_fun} \alias{set_summary_fun} \alias{set_kernel_fun} -\alias{seed_lfmcmc} \alias{set_par_names} \alias{set_stats_names} \alias{print.epiworld_lfmcmc} @@ -31,8 +30,6 @@ set_summary_fun(lfmcmc, fun) set_kernel_fun(lfmcmc, fun) -seed_lfmcmc(lfmcmc, s) - set_par_names(lfmcmc, names) set_stats_names(lfmcmc, names) @@ -58,8 +55,6 @@ use_kernel_fun_gaussian(lfmcmc) \item{fun}{The LFMCMC kernel function} -\item{s}{The rand engine seed} - \item{names}{The model stats names} \item{x}{LFMCMC model to print} @@ -83,8 +78,6 @@ The lfmcmc model with the summary function added The lfmcmc model with the kernel function added -The lfmcmc model with the seed set - The lfmcmc model with the parameter names added The lfmcmc model with the stats names added diff --git a/src/cpp11.cpp b/src/cpp11.cpp index e7662ef0..42c1fb83 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -454,13 +454,6 @@ extern "C" SEXP _epiworldR_use_kernel_fun_gaussian_cpp(SEXP lfmcmc) { 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 - return cpp11::as_sexp(seed_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>(s))); - END_CPP11 -} -// lfmcmc.cpp SEXP set_par_names_cpp(SEXP lfmcmc, std::vector< std::string > names); extern "C" SEXP _epiworldR_set_par_names_cpp(SEXP lfmcmc, SEXP names) { BEGIN_CPP11 @@ -1094,7 +1087,6 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_run_cpp", (DL_FUNC) &_epiworldR_run_cpp, 3}, {"_epiworldR_run_lfmcmc_cpp", (DL_FUNC) &_epiworldR_run_lfmcmc_cpp, 4}, {"_epiworldR_run_multiple_cpp", (DL_FUNC) &_epiworldR_run_multiple_cpp, 8}, - {"_epiworldR_seed_lfmcmc_cpp", (DL_FUNC) &_epiworldR_seed_lfmcmc_cpp, 2}, {"_epiworldR_set_agents_data_cpp", (DL_FUNC) &_epiworldR_set_agents_data_cpp, 3}, {"_epiworldR_set_death_reduction_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_cpp, 2}, {"_epiworldR_set_death_reduction_fun_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_fun_cpp, 3}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 6dcd6d81..af42f326 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -149,16 +149,6 @@ SEXP use_kernel_fun_gaussian_cpp( return lfmcmc; } -[[cpp11::register]] -SEXP seed_lfmcmc_cpp( - SEXP lfmcmc, - unsigned long long int s -) { - WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->seed(s); - return lfmcmc; -} - [[cpp11::register]] SEXP set_par_names_cpp( SEXP lfmcmc, From bdc3a0fc29d5799e021e6aa29f0039730707b546 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 10:55:38 -0700 Subject: [PATCH 59/70] Add seed to run_lfmcmc --- R/LFMCMC.R | 8 +++++--- R/cpp11.R | 4 ++-- man/LFMCMC.Rd | 4 +++- src/cpp11.cpp | 8 ++++---- src/lfmcmc.cpp | 5 +++-- vignettes/likelihood-free-mcmc.Rmd | 3 ++- 6 files changed, 19 insertions(+), 13 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 05b573e7..507a0705 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -27,13 +27,15 @@ LFMCMC <- function(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_) UseMethod("run_lfmcmc") +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_) { - run_lfmcmc_cpp(lfmcmc, params_init_, n_samples_, epsilon_) +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) } diff --git a/R/cpp11.R b/R/cpp11.R index b0e2fa1b..d699a510 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -224,8 +224,8 @@ LFMCMC_cpp <- function(model) { .Call(`_epiworldR_LFMCMC_cpp`, model) } -run_lfmcmc_cpp <- function(lfmcmc, params_init_, n_samples_, epsilon_) { - .Call(`_epiworldR_run_lfmcmc_cpp`, lfmcmc, params_init_, n_samples_, epsilon_) +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_) { diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 558368e4..eaa4bae4 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -18,7 +18,7 @@ \usage{ LFMCMC(model) -run_lfmcmc(lfmcmc, params_init_, n_samples_, epsilon_) +run_lfmcmc(lfmcmc, params_init_, n_samples_, epsilon_, seed = NULL) set_observed_data(lfmcmc, observed_data_) @@ -51,6 +51,8 @@ use_kernel_fun_gaussian(lfmcmc) \item{epsilon_}{Epsilon parameter} +\item{seed}{Random engine seed} + \item{observed_data_}{Observed data} \item{fun}{The LFMCMC kernel function} diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 42c1fb83..a50bdc74 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -398,10 +398,10 @@ extern "C" SEXP _epiworldR_LFMCMC_cpp(SEXP model) { END_CPP11 } // lfmcmc.cpp -SEXP run_lfmcmc_cpp(SEXP lfmcmc, std::vector params_init_, size_t n_samples_, epiworld_double epsilon_); -extern "C" SEXP _epiworldR_run_lfmcmc_cpp(SEXP lfmcmc, SEXP params_init_, SEXP n_samples_, SEXP epsilon_) { +SEXP run_lfmcmc_cpp(SEXP lfmcmc, std::vector params_init_, size_t n_samples_, epiworld_double epsilon_, int seed); +extern "C" SEXP _epiworldR_run_lfmcmc_cpp(SEXP lfmcmc, SEXP params_init_, SEXP n_samples_, SEXP epsilon_, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(run_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(params_init_), cpp11::as_cpp>(n_samples_), cpp11::as_cpp>(epsilon_))); + return cpp11::as_sexp(run_lfmcmc_cpp(cpp11::as_cpp>(lfmcmc), cpp11::as_cpp>>(params_init_), cpp11::as_cpp>(n_samples_), cpp11::as_cpp>(epsilon_), cpp11::as_cpp>(seed))); END_CPP11 } // lfmcmc.cpp @@ -1085,7 +1085,7 @@ static const R_CallMethodDef CallEntries[] = { {"_epiworldR_rm_tool_cpp", (DL_FUNC) &_epiworldR_rm_tool_cpp, 2}, {"_epiworldR_rm_virus_cpp", (DL_FUNC) &_epiworldR_rm_virus_cpp, 2}, {"_epiworldR_run_cpp", (DL_FUNC) &_epiworldR_run_cpp, 3}, - {"_epiworldR_run_lfmcmc_cpp", (DL_FUNC) &_epiworldR_run_lfmcmc_cpp, 4}, + {"_epiworldR_run_lfmcmc_cpp", (DL_FUNC) &_epiworldR_run_lfmcmc_cpp, 5}, {"_epiworldR_run_multiple_cpp", (DL_FUNC) &_epiworldR_run_multiple_cpp, 8}, {"_epiworldR_set_agents_data_cpp", (DL_FUNC) &_epiworldR_set_agents_data_cpp, 3}, {"_epiworldR_set_death_reduction_cpp", (DL_FUNC) &_epiworldR_set_death_reduction_cpp, 2}, diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index af42f326..b8295b64 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -35,10 +35,11 @@ SEXP run_lfmcmc_cpp( SEXP lfmcmc, std::vector params_init_, size_t n_samples_, - epiworld_double epsilon_ + epiworld_double epsilon_, + int seed ) { WrapLFMCMC(lfmcmc_ptr)(lfmcmc); - lfmcmc_ptr->run(params_init_, n_samples_, epsilon_); + lfmcmc_ptr->run(params_init_, n_samples_, epsilon_, seed); return lfmcmc; } diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 8f61a654..4f1ec3f4 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -101,7 +101,8 @@ run_lfmcmc( lfmcmc = lfmcmc_model, params_init_ = par0, n_samples_ = n_samp, - epsilon_ = epsil + epsilon_ = epsil, + seed = model_seed ) # Print the results From 81ed52b8a28c4e0fb20ea11b589b0a456edd3ffe Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 11:00:59 -0700 Subject: [PATCH 60/70] Update LFMCMC.R to match order of lfmcmc.cpp --- R/LFMCMC.R | 36 ++++++++++++++++++------------------ man/LFMCMC.Rd | 22 +++++++++++----------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 507a0705..20a64e5c 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -65,6 +65,15 @@ set_proposal_fun.epiworld_lfmcmc <- function(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 @@ -104,6 +113,15 @@ set_kernel_fun.epiworld_lfmcmc <- function(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 @@ -139,21 +157,3 @@ print.epiworld_lfmcmc <- function(x, ...) { print_lfmcmc_cpp(x) invisible(x) } - -#' @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 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) -} diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index eaa4bae4..eaa6d427 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -6,14 +6,14 @@ \alias{run_lfmcmc} \alias{set_observed_data} \alias{set_proposal_fun} +\alias{use_proposal_norm_reflective} \alias{set_simulation_fun} \alias{set_summary_fun} \alias{set_kernel_fun} +\alias{use_kernel_fun_gaussian} \alias{set_par_names} \alias{set_stats_names} \alias{print.epiworld_lfmcmc} -\alias{use_proposal_norm_reflective} -\alias{use_kernel_fun_gaussian} \title{Likelihood-Free Markhov Chain Monte Carlo (LFMCMC)} \usage{ LFMCMC(model) @@ -24,26 +24,26 @@ set_observed_data(lfmcmc, observed_data_) set_proposal_fun(lfmcmc, fun) +use_proposal_norm_reflective(lfmcmc) + set_simulation_fun(lfmcmc, fun) set_summary_fun(lfmcmc, fun) set_kernel_fun(lfmcmc, fun) +use_kernel_fun_gaussian(lfmcmc) + set_par_names(lfmcmc, names) set_stats_names(lfmcmc, names) \method{print}{epiworld_lfmcmc}(x, ...) - -use_proposal_norm_reflective(lfmcmc) - -use_kernel_fun_gaussian(lfmcmc) } \arguments{ \item{model}{A model of class \link{epiworld_model}} -\item{lfmcmc}{The LFMCMC model} +\item{lfmcmc}{LFMCMC model} \item{params_init_}{Initial model parameters} @@ -74,21 +74,21 @@ The lfmcmc model with the observed data added The lfmcmc model with the proposal function added +The LFMCMC model with proposal function set to norm reflective + The lfmcmc model with the simulation function added The lfmcmc model with the summary function added The lfmcmc model with the kernel function added +The LFMCMC model with kernel function set to gaussian + The lfmcmc model with the parameter names added The lfmcmc model with the stats names added The lfmcmc model - -The LFMCMC model with proposal function set to norm reflective - -The LFMCMC model with kernel function set to gaussian } \description{ Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) From 24d8b2b673c5677dc20233c4e95c37191ce09e9e Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 11:08:03 -0700 Subject: [PATCH 61/70] Add comment blocks to lfmcmc.cpp to improve file navigation --- src/lfmcmc.cpp | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index b8295b64..ea6bf97b 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -16,6 +16,10 @@ using namespace epiworld; // LFMCMC definitions: // https://github.com/UofUEpiBio/epiworld/tree/master/include/epiworld/math/lfmcmc +// ************************************* +// LFMCMC Function +// ************************************* + [[cpp11::register]] SEXP LFMCMC_cpp( SEXP model @@ -30,6 +34,10 @@ SEXP LFMCMC_cpp( return lfmcmc_ptr; } +// ************************************* +// LFMCMC Run Function +// ************************************* + [[cpp11::register]] SEXP run_lfmcmc_cpp( SEXP lfmcmc, @@ -43,6 +51,10 @@ SEXP run_lfmcmc_cpp( return lfmcmc; } +// ************************************* +// LFMCMC Setup Functions +// ************************************* + // observed_data_ should be of type TData [[cpp11::register]] SEXP set_observed_data_cpp( @@ -150,6 +162,10 @@ SEXP use_kernel_fun_gaussian_cpp( return lfmcmc; } +// ************************************* +// LFMCMC Printing Functions +// ************************************* + [[cpp11::register]] SEXP set_par_names_cpp( SEXP lfmcmc, From 9eca06f1209667931e1b26fad677ba4d9cbd403d Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 11:58:19 -0700 Subject: [PATCH 62/70] Implement set_kernel_fun --- src/lfmcmc.cpp | 20 +++++++++++++++++++- vignettes/likelihood-free-mcmc.Rmd | 13 ++++++++++++- 2 files changed, 31 insertions(+), 2 deletions(-) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index ea6bf97b..92daf714 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -147,7 +147,25 @@ SEXP set_kernel_fun_cpp( SEXP lfmcmc, cpp11::function fun ) { - cpp11::stop("Unimplemented"); + + LFMCMCKernelFun fun_call = [fun]( + const std::vector< epiworld_double >& stats_now, + const std::vector< epiworld_double >& stats_obs, + epiworld_double epsilon, + LFMCMC* + ) -> epiworld_double { + + auto stats_now_doubles = cpp11::doubles(stats_now); + auto stats_obs_doubles = cpp11::doubles(stats_obs); + + return cpp11::as_cpp( + fun(stats_now_doubles, stats_obs_doubles, epsilon) + ); + }; + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + + lfmcmc_ptr->set_kernel_fun(fun_call); return lfmcmc; } diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index 4f1ec3f4..edc0e75e 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -80,12 +80,23 @@ sumfun <- function(dat) { return(dat) } +# Define the LFMCMC kernel function +# - Based on kernel_fun_uniform from lfmcmc-meat.hpp +kernelfun <- function(stats_now, stats_obs, epsilon) { + + ans <- sum(mapply(function(v1, v2) (v1 - v2)^2, + stats_obs, + stats_now)) + + return(ifelse(sqrt(ans) < epsilon, 1.0, 0.0)) +} + # Create the LFMCMC model using a norm reflective proposal function and a Gaussian kernel function lfmcmc_model <- LFMCMC(model_sir) |> set_simulation_fun(simfun) |> set_summary_fun(sumfun) |> use_proposal_norm_reflective() |> - use_kernel_fun_gaussian() |> + set_kernel_fun(kernelfun) |> set_observed_data(obs_data) ``` From 822a52224a2be9f28a049e7247a10f53ae9f9203 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 12:33:06 -0700 Subject: [PATCH 63/70] Implement set_proposal_fun --- src/lfmcmc.cpp | 23 ++++++++++++++++++++++- vignettes/likelihood-free-mcmc.Rmd | 8 +++++++- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/src/lfmcmc.cpp b/src/lfmcmc.cpp index 92daf714..075d4017 100644 --- a/src/lfmcmc.cpp +++ b/src/lfmcmc.cpp @@ -72,7 +72,28 @@ SEXP set_proposal_fun_cpp( cpp11::function fun ) { - cpp11::stop("Un implemented"); + LFMCMCProposalFun fun_call = [fun]( + std::vector< epiworld_double >& params_now, + const std::vector< epiworld_double >& params_prev, + LFMCMC* + ) -> void { + + auto params_doubles = cpp11::doubles(params_prev); + + auto res_tmp = cpp11::doubles(fun(params_doubles)); + + std::copy( + res_tmp.begin(), + res_tmp.end(), + params_now.begin() + ); + + return; + }; + + WrapLFMCMC(lfmcmc_ptr)(lfmcmc); + + lfmcmc_ptr->set_proposal_fun(fun_call); return lfmcmc; } diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index edc0e75e..b694e956 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -80,6 +80,12 @@ sumfun <- function(dat) { return(dat) } +# Define the LFMCMC proposal function +propfun <- function(params_prev) { + res <- params_prev + rnorm(length(params_prev), ) + return(res) +} + # Define the LFMCMC kernel function # - Based on kernel_fun_uniform from lfmcmc-meat.hpp kernelfun <- function(stats_now, stats_obs, epsilon) { @@ -95,7 +101,7 @@ kernelfun <- function(stats_now, stats_obs, epsilon) { lfmcmc_model <- LFMCMC(model_sir) |> set_simulation_fun(simfun) |> set_summary_fun(sumfun) |> - use_proposal_norm_reflective() |> + set_proposal_fun(propfun) |> set_kernel_fun(kernelfun) |> set_observed_data(obs_data) ``` From 16461b2f43b2f91566a641704c11dd26ae916784 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 12:36:12 -0700 Subject: [PATCH 64/70] Update comments in vignette --- vignettes/likelihood-free-mcmc.Rmd | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/vignettes/likelihood-free-mcmc.Rmd b/vignettes/likelihood-free-mcmc.Rmd index b694e956..c5e87fe4 100644 --- a/vignettes/likelihood-free-mcmc.Rmd +++ b/vignettes/likelihood-free-mcmc.Rmd @@ -81,6 +81,7 @@ sumfun <- function(dat) { } # Define the LFMCMC proposal function +# - Based on proposal_fun_normal from lfmcmc-meat.hpp propfun <- function(params_prev) { res <- params_prev + rnorm(length(params_prev), ) return(res) @@ -97,7 +98,7 @@ kernelfun <- function(stats_now, stats_obs, epsilon) { return(ifelse(sqrt(ans) < epsilon, 1.0, 0.0)) } -# Create the LFMCMC model using a norm reflective proposal function and a Gaussian kernel function +# Create the LFMCMC model lfmcmc_model <- LFMCMC(model_sir) |> set_simulation_fun(simfun) |> set_summary_fun(sumfun) |> From 1f1e43f85e21795ec31312f49dffe8481de5488b Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 12:44:27 -0700 Subject: [PATCH 65/70] Sync with c++ library --- inst/include/epiworld/epiworld.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/include/epiworld/epiworld.hpp b/inst/include/epiworld/epiworld.hpp index 398bf6c7..34501f93 100644 --- a/inst/include/epiworld/epiworld.hpp +++ b/inst/include/epiworld/epiworld.hpp @@ -19,7 +19,7 @@ /* Versioning */ #define EPIWORLD_VERSION_MAJOR 0 #define EPIWORLD_VERSION_MINOR 4 -#define EPIWORLD_VERSION_PATCH 1 +#define EPIWORLD_VERSION_PATCH 2 static const int epiworld_version_major = EPIWORLD_VERSION_MAJOR; static const int epiworld_version_minor = EPIWORLD_VERSION_MINOR; From d9a2f48fc582682b01632a5718c739e1a26b98be Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 13:20:12 -0700 Subject: [PATCH 66/70] Fill out fields for roxygen docs of LFMCMC --- R/LFMCMC.R | 69 ++++++++++++++++++++++++++++++++++++++++++++----- man/LFMCMC.Rd | 71 +++++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 126 insertions(+), 14 deletions(-) diff --git a/R/LFMCMC.R b/R/LFMCMC.R index 20a64e5c..efcc8a8c 100644 --- a/R/LFMCMC.R +++ b/R/LFMCMC.R @@ -3,14 +3,71 @@ #' #' @aliases epiworld_lfmcmc #' @details -#' TODO: Detail LFMCMC +#' 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]. +#' The `LFMCMC` function returns a model of class [epiworld_lfmcmc]. #' @examples -#' model_sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, -#' transmission_rate = 0.9, recovery_rate = 0.1) -#' model_lfmcmc <- LFMCMC(model_sir) +#' ## 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")) @@ -28,7 +85,7 @@ LFMCMC <- function(model) { #' @param n_samples_ Number of samples #' @param epsilon_ Epsilon parameter #' @param seed Random engine seed -#' @returns The simulated model of class `epiworld_lfmcmc`. +#' @returns The simulated model of class [epiworld_lfmcmc]. #' @export run_lfmcmc <- function(lfmcmc, params_init_, n_samples_, epsilon_, seed = NULL) UseMethod("run_lfmcmc") diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index eaa6d427..3081b364 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -64,11 +64,9 @@ set_stats_names(lfmcmc, names) \item{...}{Ignored} } \value{ -\itemize{ -\item The \code{LFMCMC}function returns a model of class \link{epiworld_lfmcmc}. -} +The \code{LFMCMC} function returns a model of class \link{epiworld_lfmcmc}. -The simulated model of class \code{epiworld_lfmcmc}. +The simulated model of class \link{epiworld_lfmcmc}. The lfmcmc model with the observed data added @@ -94,10 +92,67 @@ The lfmcmc model Likelihood-Free Markhov Chain Monte Carlo (LFMCMC) } \details{ -TODO: Detail LFMCMC +Performs a Likelihood-Free Markhov Chain Monte Carlo simulation } \examples{ -model_sir <- ModelSIR(name = "COVID-19", prevalence = 0.01, - transmission_rate = 0.9, recovery_rate = 0.1) -model_lfmcmc <- LFMCMC(model_sir) +## 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) } From 5870f7ee92c4792e1533fcc3452aed1c5a411dae Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Mon, 4 Nov 2024 13:51:19 -0700 Subject: [PATCH 67/70] Create test-lfmcmc.R and populate with example from vignette --- inst/tinytest/test-lfmcmc.R | 96 +++++++++++++++++++++++++++++++++++++ man/LFMCMC.Rd | 4 +- 2 files changed, 98 insertions(+), 2 deletions(-) create mode 100644 inst/tinytest/test-lfmcmc.R diff --git a/inst/tinytest/test-lfmcmc.R b/inst/tinytest/test-lfmcmc.R new file mode 100644 index 00000000..470c4bbf --- /dev/null +++ b/inst/tinytest/test-lfmcmc.R @@ -0,0 +1,96 @@ +# Create Model to use in LFMCMC 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 LFMCMC 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 LFMCMC summary function +sumfun <- function(dat) { + return(dat) +} + +## Define the LFMCMC proposal function +## - Based on proposal_fun_normal from lfmcmc-meat.hpp +propfun <- function(params_prev) { + res <- params_prev + rnorm(length(params_prev), ) + return(res) +} + +## Define the LFMCMC kernel function +## - Based on kernel_fun_uniform from lfmcmc-meat.hpp +kernelfun <- function(stats_now, stats_obs, epsilon) { + + ans <- sum(mapply(function(v1, v2) (v1 - v2)^2, + stats_obs, + stats_now)) + + return(ifelse(sqrt(ans) < epsilon, 1.0, 0.0)) +} + +## Create the LFMCMC model +lfmcmc_model <- LFMCMC(model_sir) |> + set_simulation_fun(simfun) |> + set_summary_fun(sumfun) |> + set_proposal_fun(propfun) |> + set_kernel_fun(kernelfun) |> + 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) \ No newline at end of file diff --git a/man/LFMCMC.Rd b/man/LFMCMC.Rd index 3081b364..2bf04342 100644 --- a/man/LFMCMC.Rd +++ b/man/LFMCMC.Rd @@ -97,8 +97,8 @@ Performs a Likelihood-Free Markhov Chain Monte Carlo simulation \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) +model_sir <- ModelSIR(name = "COVID-19", prevalence = .1, + transmission_rate = .9, recovery_rate = .3) agents_smallworld( model_sir, n = 1000, From 5e298d8d0a6326d6669db9611730127d3504f406 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Tue, 5 Nov 2024 08:26:46 -0700 Subject: [PATCH 68/70] Sync with C++ epiworld library --- inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp index 38cbf56b..363fb766 100755 --- a/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp +++ b/inst/include/epiworld/math/lfmcmc/lfmcmc-meat-print.hpp @@ -52,7 +52,7 @@ inline void LFMCMC::print() printf_epiworld("___________________________________________\n\n"); printf_epiworld("LIKELIHOOD-FREE MARKOV CHAIN MONTE CARLO\n\n"); - printf_epiworld("N Samples : %ld\n", n_samples); + printf_epiworld("N Samples : %zu\n", n_samples); std::string abbr; epiworld_double elapsed; From 5cb9fa93b5033f440cc4342b9b2a05bac29dd4e5 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Tue, 5 Nov 2024 08:52:03 -0700 Subject: [PATCH 69/70] Sync with c++ epiworld library --- inst/include/epiworld/epiworld.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/include/epiworld/epiworld.hpp b/inst/include/epiworld/epiworld.hpp index 34501f93..6a060f7e 100644 --- a/inst/include/epiworld/epiworld.hpp +++ b/inst/include/epiworld/epiworld.hpp @@ -19,7 +19,7 @@ /* Versioning */ #define EPIWORLD_VERSION_MAJOR 0 #define EPIWORLD_VERSION_MINOR 4 -#define EPIWORLD_VERSION_PATCH 2 +#define EPIWORLD_VERSION_PATCH 3 static const int epiworld_version_major = EPIWORLD_VERSION_MAJOR; static const int epiworld_version_minor = EPIWORLD_VERSION_MINOR; From 48c220d2276c4b5b9f11d963f039fba20c2cb1d8 Mon Sep 17 00:00:00 2001 From: Andrew Pulsipher Date: Tue, 5 Nov 2024 11:49:05 -0700 Subject: [PATCH 70/70] Update version number to match C++ library --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index e98c661e..bd48843f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: epiworldR Type: Package Title: Fast Agent-Based Epi Models -Version: 0.3-2 +Version: 0.4-3 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")),