Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Renaming variables for consistency with C++ library #66

Merged
merged 9 commits into from
Dec 16, 2024
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: epiworldR
Type: Package
Title: Fast Agent-Based Epi Models
Version: 0.6-0
Version: 0.6-0.0
Authors@R: c(
person(given="George", family="Vega Yon", role=c("aut","cre"),
email="[email protected]", comment = c(ORCID = "0000-0002-3171-0844")),
Expand Down
17 changes: 14 additions & 3 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -125,12 +125,22 @@ export(distribute_virus_set)
export(entity)
export(entity_add_agent)
export(entity_get_agents)
export(get_accepted_params)
export(get_accepted_stats)
export(get_agents)
export(get_agents_data_ncols)
export(get_agents_states)
export(get_agents_tools)
export(get_all_accepted_kernel_scores)
export(get_all_accepted_params)
export(get_all_accepted_stats)
export(get_all_sample_acceptance)
export(get_all_sample_drawn_prob)
export(get_all_sample_kernel_scores)
export(get_all_sample_params)
export(get_all_sample_stats)
export(get_current_accepted_params)
export(get_current_accepted_stats)
export(get_current_proposed_params)
export(get_current_proposed_stats)
apulsipher marked this conversation as resolved.
Show resolved Hide resolved
export(get_entities)
export(get_entity_name)
export(get_entity_size)
Expand All @@ -139,6 +149,7 @@ export(get_hist_tool)
export(get_hist_total)
export(get_hist_transition_matrix)
export(get_hist_virus)
export(get_initial_params)
export(get_mean_params)
export(get_mean_stats)
export(get_n_params)
Expand All @@ -152,9 +163,9 @@ export(get_name_tool)
export(get_name_virus)
export(get_ndays)
export(get_network)
export(get_observed_stats)
export(get_param)
export(get_reproductive_number)
export(get_sample_stats)
export(get_state)
export(get_states)
export(get_today_total)
Expand Down
231 changes: 186 additions & 45 deletions R/LFMCMC.R
Original file line number Diff line number Diff line change
Expand Up @@ -220,82 +220,110 @@ use_kernel_fun_gaussian <- function(lfmcmc) {
}

#' @rdname LFMCMC
#' @param names Character vector of names.
#' @returns
#' - `set_params_names`: The lfmcmc model with the parameter names added.
#' - `get_mean_params`: The param means for the given lfmcmc model.
#' @export
set_params_names <- function(lfmcmc, names) {
get_mean_params <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
set_params_names_cpp(lfmcmc, names)
invisible(lfmcmc)
get_mean_params_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @returns
#' - `set_stats_names`: The lfmcmc model with the stats names added.
#' - `get_mean_stats`: The stats means for the given lfmcmc model.
#' @export
set_stats_names <- function(lfmcmc, names) {
get_mean_stats <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
set_stats_names_cpp(lfmcmc, names)
invisible(lfmcmc)
get_mean_stats_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - `get_mean_params`: The param means for the given lfmcmc model.
#' - The function `get_initial_params` returns the initial parameters
#' for the given LFMCMC model.
get_initial_params <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_initial_params_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
get_mean_params <- function(lfmcmc) {
#' @returns
#' - The function `get_current_proposed_params` returns the proposed parameters
#' for the next LFMCMC sample.
get_current_proposed_params <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_mean_params_cpp(lfmcmc)
get_current_proposed_params_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - `get_mean_stats`: The stats means for the given lfmcmc model.
#' - The function `get_current_accepted_params` returns the most recently accepted
#' parameters (the current state of the LFMCMC)
get_current_accepted_params <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_current_accepted_params_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
get_mean_stats <- function(lfmcmc) {
#' @returns
#' - The function `get_current_proposed_stats` returns the statistics
#' from the simulation run with the proposed parameters
get_current_proposed_stats <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_mean_stats_cpp(lfmcmc)
get_current_proposed_stats_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @param x LFMCMC model to print
#' @param ... Ignored
#' @param burnin Integer. Number of samples to discard as burnin before
#' computing the summary.
#' @export
print.epiworld_lfmcmc <- function(x, burnin = 0, ...) {
#' @returns
#' - The function `get_current_accepted_stats` returns the statistics
#' from the most recently accepted parameters
get_current_accepted_stats <- function(lfmcmc) {

if (!is.numeric(burnin))
stop("The 'burnin' argument must be an integer.")
stopifnot_lfmcmc(lfmcmc)
get_current_accepted_stats_cpp(lfmcmc)

if (burnin < 0)
stop("The 'burnin' argument must be a non-negative integer.")
}

print_lfmcmc_cpp(x, burnin = burnin)
invisible(x)
#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_observed_stats` returns the statistics
#' for the observed data
get_observed_stats <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_observed_stats_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_accepted_params` returns a matrix of accepted
#' - The function `get_all_sample_params` returns a matrix of sample
#' parameters for the given LFMCMC model. with the number of rows equal to the
#' number of samples and the number of columns equal to the number of
#' parameters.
get_accepted_params <- function(lfmcmc) {
get_all_sample_params <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
a_params <- get_accepted_params_cpp(lfmcmc)
a_params <- get_all_sample_params_cpp(lfmcmc)
n_params <- get_n_params(lfmcmc)

matrix(
Expand All @@ -306,57 +334,126 @@ get_accepted_params <- function(lfmcmc) {

}


#' @rdname LFMCMC
#' @export
#' @rdname LFMCMC
#' @returns
#' - The function `get_accepted_stats` returns a matrix of accepted statistics
#' - The function `get_all_sample_stats` returns a matrix of statistics
#' for the given LFMCMC model. with the number of rows equal to the number of
#' samples and the number of columns equal to the number of statistics.
get_accepted_stats <- function(lfmcmc) {
get_all_sample_stats <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
a_stats <- get_accepted_stats_cpp(lfmcmc)
stats <- get_all_sample_stats_cpp(lfmcmc)
n_stats <- get_n_stats(lfmcmc)

matrix(
a_stats,
stats,
ncol = n_stats,
byrow = TRUE
)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_all_sample_acceptance` returns a vector of boolean flags
#' which indicate whether a given sample was accepted
get_all_sample_acceptance <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_all_sample_acceptance_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_all_sample_drawn_prob` returns a vector of drawn probabilities
#' for each sample
get_all_sample_drawn_prob <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_all_sample_drawn_prob_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_all_sample_kernel_scores` returns a vector of kernel scores for
#' each sample
get_all_sample_kernel_scores <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_all_sample_kernel_scores_cpp(lfmcmc)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_all_accepted_params` returns a matrix of accepted
#' parameters for the given LFMCMC model. with the number of rows equal to the
#' number of samples and the number of columns equal to the number of
#' parameters.
get_all_accepted_params <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
a_params <- get_all_accepted_params_cpp(lfmcmc)
n_params <- get_n_params(lfmcmc)

matrix(
a_params,
ncol = n_params,
byrow = TRUE
)

}


#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_sample_stats` returns a matrix of statistics
#' - The function `get_all_accepted_stats` returns a matrix of accepted statistics
#' for the given LFMCMC model. with the number of rows equal to the number of
#' samples and the number of columns equal to the number of statistics.
get_sample_stats <- function(lfmcmc) {
get_all_accepted_stats <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
stats <- get_sample_stats_cpp(lfmcmc)
a_stats <- get_all_accepted_stats_cpp(lfmcmc)
n_stats <- get_n_stats(lfmcmc)

matrix(
stats,
a_stats,
ncol = n_stats,
byrow = TRUE
)

}

#' @rdname LFMCMC
#' @export
#' @returns
#' - The function `get_all_accepted_kernel_scores` returns a vector of kernel scores for
#' each accepted sample
get_all_accepted_kernel_scores <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_all_accepted_kernel_scores_cpp(lfmcmc)

}

#' @export
#' @rdname LFMCMC
#' @returns
#' - The functions `get_n_params`, `get_n_stats`, and `get_n_samples`
#' return the number of parameters, statistics, and samples for the given
#' - The functions `get_n_samples`, `get_n_stats`, and `get_n_params`
#' return the number of samples, statistics, and parameters for the given
#' LFMCMC model, respectively.
get_n_params <- function(lfmcmc) {
get_n_samples <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_n_params_cpp(lfmcmc)
get_n_samples_cpp(lfmcmc)

}

Expand All @@ -371,10 +468,10 @@ get_n_stats <- function(lfmcmc) {

#' @export
#' @rdname LFMCMC
get_n_samples <- function(lfmcmc) {
get_n_params <- function(lfmcmc) {

stopifnot_lfmcmc(lfmcmc)
get_n_samples_cpp(lfmcmc)
get_n_params_cpp(lfmcmc)

}

Expand All @@ -396,3 +493,47 @@ verbose_off.epiworld_lfmcmc <- function(x) {
verbose_on.epiworld_lfmcmc <- function(x) {
invisible(verbose_on_lfmcmc_cpp(x))
}

#' @rdname LFMCMC
#' @param names Character vector of names.
#' @returns
#' - `set_params_names`: The lfmcmc model with the parameter names added.
#' @export
set_params_names <- function(lfmcmc, names) {

stopifnot_lfmcmc(lfmcmc)
set_params_names_cpp(lfmcmc, names)
invisible(lfmcmc)

}

#' @rdname LFMCMC
#' @returns
#' - `set_stats_names`: The lfmcmc model with the stats names added.
#' @export
set_stats_names <- function(lfmcmc, names) {

stopifnot_lfmcmc(lfmcmc)
set_stats_names_cpp(lfmcmc, names)
invisible(lfmcmc)

}

#' @rdname LFMCMC
#' @param x LFMCMC model to print
#' @param ... Ignored
#' @param burnin Integer. Number of samples to discard as burnin before
#' computing the summary.
#' @export
print.epiworld_lfmcmc <- function(x, burnin = 0, ...) {

if (!is.numeric(burnin))
stop("The 'burnin' argument must be an integer.")

if (burnin < 0)
stop("The 'burnin' argument must be a non-negative integer.")

print_lfmcmc_cpp(x, burnin = burnin)
invisible(x)

}
Loading
Loading