├── .github ├── .gitignore └── workflows │ ├── R-CMD-check.yaml │ └── test-coverage.yaml ├── vignettes └── .gitignore ├── LICENSE ├── data └── Maryland.rda ├── tests ├── testthat.R └── testthat │ ├── invalid_xml.xml │ ├── test_xml_less_than.xml │ ├── test-translate_extrema.R │ ├── test-translate_math_funs.R │ ├── test-output_utils.R │ ├── test-priors.R │ ├── test-simulator_utils.R │ ├── test-translate_time_builtins.R │ ├── test-stat_funs.R │ ├── test-comparison_operators.R │ ├── test-stan_postprocessing.R │ ├── test-summaries.R │ ├── test-prior_checks.R │ ├── test-Vensim_workarounds.R │ ├── SEIR_C_meas.stan │ ├── test-arrange_variables.R │ ├── test-what_if_from_time.R │ ├── test_stan_files │ ├── SEIR_pois_N.stan │ ├── SEIR_nbin_data_init.stan │ ├── SE3I3R_pois.stan │ ├── LV.stan │ ├── SEIR_age_pois.stan │ └── SEIR_age_nbin.stan │ ├── SEIR_normal.stan │ ├── SEIR_nbinom.stan │ ├── test-arrays.R │ ├── SEIR_nbinom_data_param.stan │ ├── 2d_pop.xmile │ ├── test-interpreters.R │ ├── test-stan_params.R │ ├── test-stan_data.R │ ├── test-stan_utils.R │ ├── test-posterior_fun.R │ ├── test-sanitise_xml.R │ ├── test-xmile_graph_funs.R │ ├── test-extract_variables.R │ ├── test-logical_operators.R │ ├── SEjIkR.xmile │ ├── test-if_else_builtins.R │ ├── test-SBC.R │ ├── test-generate_igraph_inputs.R │ └── test_models │ └── SEIR_simlin.stmx ├── inst └── models │ └── SIR_diagram.png ├── .gitignore ├── .Rbuildignore ├── R ├── regex_patterns.R ├── fun_gen_utils.R ├── translate_extrema.R ├── translate_time_builtins.R ├── comparison_operators.R ├── data.R ├── par_trans.R ├── simulator_utils.R ├── sanitise_xml.R ├── translate_math_funs.R ├── output_utils.R ├── summaries.R ├── logical_operators.R ├── utils.R ├── stan_data.R ├── stan_params.R ├── xmile_graph_funs.R ├── Vensim_workarounds.R ├── extract_variables.R ├── stat_funs.R ├── create_stan_function.R ├── arrange_variables.R ├── what_if_from_time.R ├── prior_checks.R ├── priors.R ├── stan_postprocessing.R ├── generate_igraph_inputs.R ├── stan_model.R ├── posterior_fun.R ├── interpreters.R ├── arrays.R ├── if_else_builtins.R ├── read_xmile.R ├── impact_inputs.R └── SBC.R ├── man ├── inv.Rd ├── expit.Rd ├── logit.Rd ├── reexports.Rd ├── sd_stocks.Rd ├── sd_constants.Rd ├── sd_pulse_v.Rd ├── sd_pulse_s.Rd ├── sd_net_change.Rd ├── Maryland.Rd ├── extract_timeseries_var.Rd ├── sd_fixed_delay.Rd ├── sd_pulse_train.Rd ├── sd_conf_intervals.Rd ├── sd_interpret_estimates.Rd ├── sd_simulate.Rd ├── extract_timeseries_stock.Rd ├── sd_impact_inputs.Rd ├── xmile_to_deSolve.Rd ├── stan_ode_function.Rd ├── create_stan_function.Rd ├── sd_what_if_from_time.Rd ├── sd_measurements.Rd ├── sd_data_generator_fun.Rd ├── read_xmile.Rd ├── sd_prior_checks.Rd ├── sd_prior.Rd ├── sd_posterior_fun.Rd ├── sd_sensitivity_run.Rd ├── sd_Bayes.Rd └── sd_loglik_fun.Rd ├── readsdr.Rproj ├── cran-comments.md ├── NAMESPACE ├── LICENSE.md ├── DESCRIPTION └── NEWS.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2019 2 | COPYRIGHT HOLDER: Jair Andrade 3 | -------------------------------------------------------------------------------- /data/Maryland.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandraor/readsdr/HEAD/data/Maryland.rda -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(readsdr) 3 | 4 | test_check("readsdr") 5 | -------------------------------------------------------------------------------- /inst/models/SIR_diagram.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandraor/readsdr/HEAD/inst/models/SIR_diagram.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | inst/doc 6 | doc 7 | Meta 8 | **/.DS_Store 9 | **/.Rapp.history 10 | -------------------------------------------------------------------------------- /tests/testthat/invalid_xml.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | a < b 5 | 6 | 7 | 2 | 3 | 4 | a < b 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.github$ 4 | ^README\.Rmd$ 5 | ^doc$ 6 | ^Meta$ 7 | ^cran-comments\.md$ 8 | ^CRAN-RELEASE$ 9 | ^LICENSE\.md$ 10 | ^CRAN-SUBMISSION$ 11 | -------------------------------------------------------------------------------- /R/regex_patterns.R: -------------------------------------------------------------------------------- 1 | get_pattern_regex <- function(pattern) { 2 | 3 | if(pattern == "net_flow") return ("net_flow\\((.+?)\\)") 4 | 5 | if(pattern == "var_trans") return ("log|exp|sqrt|inv\\(.+?\\)") 6 | 7 | } 8 | -------------------------------------------------------------------------------- /R/fun_gen_utils.R: -------------------------------------------------------------------------------- 1 | # Function generators utils 2 | 3 | extract_meas_pars <- function(meas_data_mdl) { 4 | 5 | meas_mdl <- lapply(meas_data_mdl, function(meas_obj) meas_obj$formula) 6 | detected_mp <- lapply(meas_mdl, extract_extra_params) %>% remove_NULL() 7 | detected_mp[!duplicated(detected_mp)] 8 | } 9 | -------------------------------------------------------------------------------- /tests/testthat/test-translate_extrema.R: -------------------------------------------------------------------------------- 1 | context("Translate extrema") 2 | 3 | 4 | test_that("translate_MIN() returns the expected translation", { 5 | expect_equal(translate_MIN("Min(0,1)"), "min(0,1)") 6 | }) 7 | 8 | test_that("translate_MAX() returns the expected translation", { 9 | expect_equal(translate_MAX("mAx(0,1)"), "max(0,1)") 10 | }) 11 | -------------------------------------------------------------------------------- /man/inv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/par_trans.R 3 | \name{inv} 4 | \alias{inv} 5 | \title{Inverse of a number} 6 | \usage{ 7 | inv(x) 8 | } 9 | \arguments{ 10 | \item{x}{A real number} 11 | } 12 | \value{ 13 | A real number 14 | } 15 | \description{ 16 | Inverse of a number 17 | } 18 | \examples{ 19 | inv(0.5) # Should return 2 20 | } 21 | -------------------------------------------------------------------------------- /tests/testthat/test-translate_math_funs.R: -------------------------------------------------------------------------------- 1 | test_that("translate_SQRT returns the expected string", { 2 | expect_equal(translate_SQRT("SQRT(x)"), "sqrt(x)") 3 | }) 4 | 5 | test_that("translate_EXP returns the expected string", { 6 | 7 | eq <- "EXP(-par_alpha*P)" 8 | actual <- translate_EXP(eq) 9 | expected <- "exp(-par_alpha*P)" 10 | 11 | expect_equal(actual, expected) 12 | }) 13 | -------------------------------------------------------------------------------- /man/expit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/par_trans.R 3 | \name{expit} 4 | \alias{expit} 5 | \title{Expit transformation} 6 | \usage{ 7 | expit(x) 8 | } 9 | \arguments{ 10 | \item{x}{A real number} 11 | } 12 | \value{ 13 | A number in the range 0 to 1 14 | } 15 | \description{ 16 | Expit transformation 17 | } 18 | \examples{ 19 | expit(-3) 20 | } 21 | -------------------------------------------------------------------------------- /tests/testthat/test-output_utils.R: -------------------------------------------------------------------------------- 1 | test_that("sd_net_change() returns the expected data.frame", { 2 | test_output <- data.frame(time = seq(0, 2, by = 0.25), 3 | C = c(0, rep(5,4), rep(20, 4))) 4 | 5 | actual_df <- sd_net_change(test_output, "C") 6 | expected_df <- data.frame(time = 1:2, value = c(5, 15), var = "delta_C") 7 | 8 | expect_equal(actual_df, expected_df) 9 | }) 10 | -------------------------------------------------------------------------------- /man/logit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/par_trans.R 3 | \name{logit} 4 | \alias{logit} 5 | \title{Logit transformation} 6 | \usage{ 7 | logit(p) 8 | } 9 | \arguments{ 10 | \item{p}{A real number that represents a probability} 11 | } 12 | \value{ 13 | An unconstrained real number 14 | } 15 | \description{ 16 | Logit transformation 17 | } 18 | \examples{ 19 | logit(0.5) 20 | } 21 | -------------------------------------------------------------------------------- /readsdr.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | -------------------------------------------------------------------------------- /R/translate_extrema.R: -------------------------------------------------------------------------------- 1 | translate_extrema <- function(equation) { 2 | translate_MIN(equation) %>% 3 | translate_MAX() 4 | } 5 | 6 | translate_MIN <- function(equation) { 7 | pattern <- stringr::regex("\\bMIN\\b", ignore_case = TRUE) 8 | stringr::str_replace_all(equation, pattern, "min") 9 | } 10 | 11 | translate_MAX <- function(equation) { 12 | pattern <- stringr::regex("\\bMAX\\b", ignore_case = TRUE) 13 | stringr::str_replace_all(equation, pattern, "max") 14 | } 15 | -------------------------------------------------------------------------------- /R/translate_time_builtins.R: -------------------------------------------------------------------------------- 1 | translate_time_builtins <- function(equation) { 2 | new_equation <- equation %>% translate_time() %>% 3 | translate_dt() 4 | } 5 | 6 | 7 | translate_time <- function(equation) { 8 | new_equation <- stringr::str_replace_all(equation, "\\bTime\\b|\\bTIME\\b", 9 | "time") 10 | } 11 | 12 | translate_dt <- function(equation) { 13 | new_equation <- stringr::str_replace_all(equation, "\\bDT\\b", "timestep()") 14 | } 15 | -------------------------------------------------------------------------------- /R/comparison_operators.R: -------------------------------------------------------------------------------- 1 | translate_comparison_operators <- function(equation) { 2 | equal_translated <- translate_equal_sign(equation) 3 | not_equal_translated <- translate_not_equal_sign(equal_translated) 4 | } 5 | 6 | translate_equal_sign <- function(equation) { 7 | new_equation <- stringr::str_replace_all(equation, "(?|=|!)=(?!=)", "==") 8 | } 9 | 10 | translate_not_equal_sign <- function(equation) { 11 | new_equation <- stringr::str_replace_all(equation, "<>", "!=") 12 | } 13 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Test environments 2 | * local macOS install, R 4.3.1 3 | * Windows Server 2022 (on Github actions), R 4.3.3 4 | * macOS 12.7.3 (on Github actions), R 4.3.3 5 | * ubuntu 22.04.4 (on Github actions), R-devel 6 | * ubuntu 22.04.4 (on Github actions), R 4.3.3 7 | * ubuntu 22.04.4 (on Github actions), R 4.2.3 8 | 9 | ## R CMD check results 10 | 11 | 0 errors | 0 warnings | 0 notes 12 | 13 | ## Downstream dependencies 14 | 15 | There are currently no downstream dependencies for this package. 16 | -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' Influenza in Maryland during the 1918 pandemic 2 | #' 3 | #' 4 | #' @format 5 | #' A data frame with 91 rows and 6 columns: 6 | #' \describe{ 7 | #' \item{Date}{Date} 8 | #' \item{Baltimore}{Cases reported in the Baltimore} 9 | #' \item{Cumberland}{Cases reported in the Cumberland} 10 | #' \item{Lonaconing}{Cases reported in the Lonaconing} 11 | #' \item{Frederick}{Cases reported in the Frederick} 12 | #' \item{Salisbury}{Cases reported in the Salisbury} 13 | #' 14 | #' } 15 | #' @source 16 | "Maryland" 17 | -------------------------------------------------------------------------------- /man/reexports.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \docType{import} 4 | \name{reexports} 5 | \alias{reexports} 6 | \alias{\%>\%} 7 | \alias{timestep} 8 | \title{Objects exported from other packages} 9 | \keyword{internal} 10 | \description{ 11 | These objects are imported from other packages. Follow the links 12 | below to see their documentation. 13 | 14 | \describe{ 15 | \item{deSolve}{\code{\link[deSolve:deSolve-internal]{timestep}}} 16 | 17 | \item{magrittr}{\code{\link[magrittr:pipe]{\%>\%}}} 18 | }} 19 | 20 | -------------------------------------------------------------------------------- /man/sd_stocks.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summaries.R 3 | \name{sd_stocks} 4 | \alias{sd_stocks} 5 | \title{Summarise the information of a model's stocks in a data frame} 6 | \usage{ 7 | sd_stocks(mdl) 8 | } 9 | \arguments{ 10 | \item{mdl}{A list which is the output from read_xmile.} 11 | } 12 | \value{ 13 | A data frame. 14 | } 15 | \description{ 16 | Summarise the information of a model's stocks in a data frame 17 | } 18 | \examples{ 19 | path <- system.file("models", "SIR.stmx", package = "readsdr") 20 | mdl <- read_xmile(path) 21 | sd_stocks(mdl) 22 | } 23 | -------------------------------------------------------------------------------- /man/sd_constants.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summaries.R 3 | \name{sd_constants} 4 | \alias{sd_constants} 5 | \title{Summarise the information of a model's constants in a data frame} 6 | \usage{ 7 | sd_constants(mdl) 8 | } 9 | \arguments{ 10 | \item{mdl}{A list which is the output from read_xmile.} 11 | } 12 | \value{ 13 | A data frame. 14 | } 15 | \description{ 16 | Summarise the information of a model's constants in a data frame 17 | } 18 | \examples{ 19 | path <- system.file("models", "SIR.stmx", package = "readsdr") 20 | mdl <- read_xmile(path) 21 | sd_constants(mdl) 22 | } 23 | -------------------------------------------------------------------------------- /man/sd_pulse_v.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/if_else_builtins.R 3 | \name{sd_pulse_v} 4 | \alias{sd_pulse_v} 5 | \title{Replicate the behaviour of the PULSE function from Vensim} 6 | \usage{ 7 | sd_pulse_v(time, startPulse, duration) 8 | } 9 | \arguments{ 10 | \item{time}{A number} 11 | 12 | \item{startPulse}{A number} 13 | 14 | \item{duration}{A number} 15 | } 16 | \value{ 17 | A number 18 | } 19 | \description{ 20 | Replicate the behaviour of the PULSE function from Vensim 21 | } 22 | \examples{ 23 | timestep <- function() 0.25 # replicates timestep() from deSolve 24 | sd_pulse_v(1, 1, 2) 25 | } 26 | -------------------------------------------------------------------------------- /R/par_trans.R: -------------------------------------------------------------------------------- 1 | #' Expit transformation 2 | #' 3 | #' @param x A real number 4 | #' 5 | #' @return A number in the range 0 to 1 6 | #' @export 7 | #' 8 | #' @examples 9 | #' expit(-3) 10 | expit <- function(x) 1 / (1 + exp(-x)) 11 | 12 | 13 | #' Logit transformation 14 | #' 15 | #' @param p A real number that represents a probability 16 | #' 17 | #' @return An unconstrained real number 18 | #' @export 19 | #' 20 | #' @examples 21 | #' logit(0.5) 22 | logit <- function(p) log(p / (1 - p)) 23 | 24 | 25 | #' Inverse of a number 26 | #' 27 | #' @param x A real number 28 | #' 29 | #' @return A real number 30 | #' @export 31 | #' 32 | #' @examples 33 | #' inv(0.5) # Should return 2 34 | inv <- function(x) 1/x 35 | -------------------------------------------------------------------------------- /man/sd_pulse_s.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/if_else_builtins.R 3 | \name{sd_pulse_s} 4 | \alias{sd_pulse_s} 5 | \title{Replicate the behaviour of the PULSE function from Stella} 6 | \usage{ 7 | sd_pulse_s(time, volume, start_p, interval) 8 | } 9 | \arguments{ 10 | \item{time}{A number} 11 | 12 | \item{volume}{A number} 13 | 14 | \item{start_p}{A number} 15 | 16 | \item{interval}{A number} 17 | } 18 | \value{ 19 | A number 20 | } 21 | \description{ 22 | This function must be placed inside the object that will be passed as the 23 | argument \code{func} to deSolve's \code{ode} function. 24 | } 25 | \examples{ 26 | timestep <- function() 0.25 # replicates timestep() from deSolve 27 | sd_pulse_s(2, 1, 2, 0) 28 | 29 | } 30 | -------------------------------------------------------------------------------- /R/simulator_utils.R: -------------------------------------------------------------------------------- 1 | configure_meas_models <- function(meas_mdl, meas_params, prior_vals) { 2 | 3 | for(meas_par_obj in meas_params) { 4 | 5 | # Parameter's name before the transformation 6 | before_name <- stringr::str_remove(meas_par_obj$par_name, 7 | paste0(meas_par_obj$par_trans, "_")) 8 | 9 | trans_value <- execute_trans(prior_vals[[meas_par_obj$par_name]], 10 | meas_par_obj$par_trans) 11 | 12 | configured_mdl <- lapply(trans_value, function(val) { 13 | 14 | lapply(meas_mdl, function(meas_obj) { 15 | 16 | stringr::str_replace(meas_obj, before_name, 17 | as.character(val)) 18 | }) 19 | }) 20 | } 21 | 22 | configured_mdl 23 | } 24 | -------------------------------------------------------------------------------- /man/sd_net_change.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/output_utils.R 3 | \name{sd_net_change} 4 | \alias{sd_net_change} 5 | \title{Estimate the net change of a stock in discrete times} 6 | \usage{ 7 | sd_net_change(sim_df, cumulative_var) 8 | } 9 | \arguments{ 10 | \item{sim_df}{A data frame with the simulation output} 11 | 12 | \item{cumulative_var}{A string that indicates to which variable the discrete 13 | change will be estimated} 14 | } 15 | \value{ 16 | A dataframe. 17 | } 18 | \description{ 19 | Estimate the net change of a stock in discrete times 20 | } 21 | \examples{ 22 | test_output <- data.frame(time = seq(0, 2, by = 0.25), 23 | C = c(0, rep(5,4), rep(20, 4))) 24 | sd_net_change(test_output, "C") 25 | } 26 | -------------------------------------------------------------------------------- /tests/testthat/test-priors.R: -------------------------------------------------------------------------------- 1 | test_that("sd_prior() returns the expected list", { 2 | 3 | actual <- sd_prior("par_beta", "lognormal", c(0, 1)) 4 | 5 | expected <- list(par_name = "par_beta", 6 | dist = "lognormal", 7 | type = "constant", 8 | mu = 0, 9 | sigma = 1, 10 | min = 0) 11 | 12 | expect_equal(actual, expected) 13 | 14 | actual <- sd_prior("par_rho", "normal", c(0, 1), min = 0) 15 | 16 | expected <- list(par_name = "par_rho", 17 | dist = "normal", 18 | type = "constant", 19 | mu = 0, 20 | sigma = 1, 21 | min = 0) 22 | 23 | expect_equal(actual, expected) 24 | }) 25 | 26 | 27 | -------------------------------------------------------------------------------- /man/Maryland.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{Maryland} 5 | \alias{Maryland} 6 | \title{Influenza in Maryland during the 1918 pandemic} 7 | \format{ 8 | A data frame with 91 rows and 6 columns: 9 | \describe{ 10 | \item{Date}{Date} 11 | \item{Baltimore}{Cases reported in the Baltimore} 12 | \item{Cumberland}{Cases reported in the Cumberland} 13 | \item{Lonaconing}{Cases reported in the Lonaconing} 14 | \item{Frederick}{Cases reported in the Frederick} 15 | \item{Salisbury}{Cases reported in the Salisbury} 16 | 17 | } 18 | } 19 | \source{ 20 | 21 | } 22 | \usage{ 23 | Maryland 24 | } 25 | \description{ 26 | Influenza in Maryland during the 1918 pandemic 27 | } 28 | \keyword{datasets} 29 | -------------------------------------------------------------------------------- /R/sanitise_xml.R: -------------------------------------------------------------------------------- 1 | sanitise_xml <- function(xml_as_text) { 2 | # pattern equations xml 3 | pattern_eq <- stringr::regex("(.+?)", dotall = TRUE) 4 | equations <- stringr::str_match_all(xml_as_text, pattern_eq)[[1]][, 2] 5 | n_eq <- length(equations) 6 | 7 | # Sanitised equations 8 | snt_equations <- equations %>% stringr::str_replace_all(">", ">") %>% 9 | stringr::str_replace_all("<", "<") 10 | sanitised_xml <- paste0("", snt_equations, "") 11 | 12 | pos_tags <- stringr::str_locate_all(xml_as_text, pattern_eq)[[1]] 13 | 14 | for(i in seq_len(nrow(pos_tags))) { 15 | pos_tags <- stringr::str_locate_all(xml_as_text, pattern_eq)[[1]] 16 | pos <- pos_tags[i, ] 17 | stringr::str_sub(xml_as_text, pos[[1]], pos[[2]]) <- sanitised_xml[[i]] 18 | } 19 | 20 | xml_as_text 21 | } 22 | -------------------------------------------------------------------------------- /tests/testthat/test-simulator_utils.R: -------------------------------------------------------------------------------- 1 | test_that("configure_meas_models() returns the expected list", { 2 | 3 | meas_mdl <- list("y ~ neg_binomial_2(net_flow(C), phi)") 4 | 5 | meas_params <- list(list(par_name = "inv_phi", 6 | dist = "exponential", 7 | beta = 5, 8 | min = 0, 9 | type = "meas_par", 10 | par_trans = "inv")) 11 | 12 | prior_vals <- list(inv_phi = c(0.62781087, 0.04486981)) 13 | 14 | actual <- configure_meas_models(meas_mdl, meas_params, prior_vals) 15 | 16 | expected <- list(list("y ~ neg_binomial_2(net_flow(C), 1.59283639036068)"), 17 | list("y ~ neg_binomial_2(net_flow(C), 22.2867001219751)")) 18 | 19 | expect_equal(actual, expected) 20 | }) 21 | -------------------------------------------------------------------------------- /tests/testthat/test-translate_time_builtins.R: -------------------------------------------------------------------------------- 1 | test_that("translate_time_builtins() returns the expected translation", { 2 | test_equation <- "ifelse(TIME > 0, DT, 0)" 3 | actual_val <- translate_time_builtins(test_equation) 4 | expected_val <- "ifelse(time > 0, timestep(), 0)" 5 | expect_equal(actual_val, expected_val) 6 | }) 7 | 8 | test_that("translate_time() returns the expected translation", { 9 | test_equation <- "Time + startTime" 10 | actual_val <- translate_time(test_equation) 11 | expected_val <- "time + startTime" 12 | expect_equal(actual_val, expected_val) 13 | }) 14 | 15 | test_that("translate_dt() returns the expected translation", { 16 | test_equation <- "volume / DT" 17 | actual_val <- translate_dt(test_equation) 18 | expected_val <- "volume / timestep()" 19 | expect_equal(actual_val, expected_val) 20 | }) 21 | -------------------------------------------------------------------------------- /R/translate_math_funs.R: -------------------------------------------------------------------------------- 1 | translate_math_funs <- function(equation) { 2 | 3 | new_equation <- translate_ABS(equation) 4 | new_equation <- translate_SQRT(new_equation) 5 | new_equation <- translate_EXP(new_equation) 6 | new_equation 7 | } 8 | 9 | translate_ABS <- function(equation) { 10 | 11 | fun_name <- "ABS" 12 | downcase_fun_name(fun_name, equation) 13 | } 14 | 15 | translate_SQRT <- function(equation) { 16 | 17 | fun_name <- "SQRT" 18 | downcase_fun_name(fun_name, equation) 19 | } 20 | 21 | translate_EXP <- function(equation) { 22 | 23 | fun_name <- "EXP" 24 | downcase_fun_name(fun_name, equation) 25 | } 26 | 27 | downcase_fun_name <- function(fun_name, equation) { 28 | 29 | pattern <- paste0("\\b", fun_name, "\\b") 30 | rgx <- stringr::regex(pattern, ignore_case = TRUE) 31 | stringr::str_replace_all(equation, rgx, tolower(fun_name)) 32 | } 33 | -------------------------------------------------------------------------------- /man/extract_timeseries_var.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stan_postprocessing.R 3 | \name{extract_timeseries_var} 4 | \alias{extract_timeseries_var} 5 | \title{Extract the values over time of a variable from a Stan fit} 6 | \usage{ 7 | extract_timeseries_var(var_name, posterior_df) 8 | } 9 | \arguments{ 10 | \item{var_name}{A string that indicates the variable's name for which the 11 | function will construct the timeseries.} 12 | 13 | \item{posterior_df}{A Stan fit object converted into a data frame} 14 | } 15 | \value{ 16 | A data frame 17 | } 18 | \description{ 19 | Extract the values over time of a variable from a Stan fit 20 | } 21 | \examples{ 22 | posterior_df <- data.frame(`var[1]` = rep(0, 2), `var[2]` = rep(1, 2), 23 | check.names = FALSE) 24 | extract_timeseries_var("var", posterior_df) 25 | } 26 | -------------------------------------------------------------------------------- /man/sd_fixed_delay.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/delay.R 3 | \name{sd_fixed_delay} 4 | \alias{sd_fixed_delay} 5 | \title{Fixed delay} 6 | \usage{ 7 | sd_fixed_delay(var, time, delay, init, .memory) 8 | } 9 | \arguments{ 10 | \item{var}{A string that indicates the delayed variable.} 11 | 12 | \item{time}{A number that indicates current simulation time.} 13 | 14 | \item{delay}{A number that indicates the delay time.} 15 | 16 | \item{init}{A number that indicates the function's output value of at the 17 | start of the simulation.} 18 | 19 | \item{.memory}{A data frame that keeps past values of delayed variables.} 20 | } 21 | \value{ 22 | A number. 23 | } 24 | \description{ 25 | Fixed delay 26 | } 27 | \examples{ 28 | .memory <- data.frame(time = 3, inflow = 3) 29 | rownames(.memory) <- 3 30 | sd_fixed_delay("inflow", 5, 2, 0, .memory) 31 | } 32 | -------------------------------------------------------------------------------- /man/sd_pulse_train.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/if_else_builtins.R 3 | \name{sd_pulse_train} 4 | \alias{sd_pulse_train} 5 | \title{PULSE TRAIN} 6 | \usage{ 7 | sd_pulse_train(time, start_pulse, duration_pulse, repeat_pt, end_pulse) 8 | } 9 | \arguments{ 10 | \item{time}{A numeric argument that indicates the current simulation time} 11 | 12 | \item{start_pulse}{A numeric argument that indicates the start of the pulse} 13 | 14 | \item{duration_pulse}{A numeric argument that indicates the width of the pulse} 15 | 16 | \item{repeat_pt}{A numeric argument that indicates the repetition pattern} 17 | 18 | \item{end_pulse}{A numeric argument that indicates the end of the sequence} 19 | } 20 | \value{ 21 | 1 during the pulse, 0 otherwise. 22 | } 23 | \description{ 24 | PULSE TRAIN 25 | } 26 | \examples{ 27 | sd_pulse_train(5, 5, 3, 10, 20) 28 | } 29 | -------------------------------------------------------------------------------- /tests/testthat/test-stat_funs.R: -------------------------------------------------------------------------------- 1 | test_that("translate_NORMAL returns the expected string", { 2 | expect_equal(translate_NORMAL("NORMAL(1,10)", "isee"), 3 | "rnorm(1,1,10)") 4 | 5 | expect_equal(translate_NORMAL("x + NORMAL(1,10)", "isee"), 6 | "x + rnorm(1,1,10)") 7 | }) 8 | 9 | test_that("translate_NORMAL throws an error when NORMAL has more than two params", { 10 | expect_error(translate_NORMAL("NORMAL(0,1,1)", "isee"), 11 | "readsdr is restricted to translate NORMAL functions with only two parameters: mean, std_dev.") 12 | }) 13 | 14 | test_that("translate_NORMAL returns the expected string for an equation from Vensim", { 15 | 16 | equation <- "RANDOM_NORMAL(0,200,Mean_of_Demand,Sd_of_Demand,0)" 17 | actual <- translate_NORMAL(equation, "Vensim") 18 | expected <- "truncnorm::rtruncnorm(1,0,200,Mean_of_Demand,Sd_of_Demand)" 19 | 20 | expect_equal(actual, expected) 21 | }) 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export("%>%") 4 | export(create_stan_function) 5 | export(expit) 6 | export(extract_timeseries_stock) 7 | export(extract_timeseries_var) 8 | export(inv) 9 | export(logit) 10 | export(read_xmile) 11 | export(sd_Bayes) 12 | export(sd_conf_intervals) 13 | export(sd_constants) 14 | export(sd_data_generator_fun) 15 | export(sd_fixed_delay) 16 | export(sd_impact_inputs) 17 | export(sd_interpret_estimates) 18 | export(sd_loglik_fun) 19 | export(sd_measurements) 20 | export(sd_net_change) 21 | export(sd_posterior_fun) 22 | export(sd_prior) 23 | export(sd_prior_checks) 24 | export(sd_pulse_s) 25 | export(sd_pulse_train) 26 | export(sd_pulse_v) 27 | export(sd_sensitivity_run) 28 | export(sd_simulate) 29 | export(sd_stocks) 30 | export(sd_what_if_from_time) 31 | export(stan_ode_function) 32 | export(timestep) 33 | export(xmile_to_deSolve) 34 | importFrom(deSolve,timestep) 35 | importFrom(magrittr,"%>%") 36 | -------------------------------------------------------------------------------- /R/output_utils.R: -------------------------------------------------------------------------------- 1 | #' Estimate the net change of a stock in discrete times 2 | #' 3 | #' @param sim_df A data frame with the simulation output 4 | #' @param cumulative_var A string that indicates to which variable the discrete 5 | #' change will be estimated 6 | #' 7 | #' @return A dataframe. 8 | #' @export 9 | #' 10 | #' @examples 11 | #' test_output <- data.frame(time = seq(0, 2, by = 0.25), 12 | #' C = c(0, rep(5,4), rep(20, 4))) 13 | #' sd_net_change(test_output, "C") 14 | 15 | sd_net_change <- function(sim_df, cumulative_var) { 16 | 17 | temp_df <- sim_df[, c("time", cumulative_var)] 18 | temp_df <- temp_df[temp_df$time - trunc(temp_df$time) == 0, ] 19 | cml_vals <- temp_df[ , cumulative_var] 20 | temp_df$value <- cml_vals - dplyr::lag(cml_vals ) 21 | temp_df <- dplyr::slice(temp_df, -1) 22 | temp_df$var <- paste0("delta_", cumulative_var) 23 | 24 | temp_df[, c("time", "value", "var")] 25 | } 26 | -------------------------------------------------------------------------------- /man/sd_conf_intervals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interpreters.R 3 | \name{sd_conf_intervals} 4 | \alias{sd_conf_intervals} 5 | \title{Calculate confidence intervals} 6 | \usage{ 7 | sd_conf_intervals(estimates, par_list, hsn, conf_level = 0.95) 8 | } 9 | \arguments{ 10 | \item{estimates}{A list or data frame} 11 | 12 | \item{par_list}{A list} 13 | 14 | \item{hsn}{Hessian matrix} 15 | 16 | \item{conf_level}{A numeric input indicating the confidence level} 17 | } 18 | \value{ 19 | A data frame. 20 | } 21 | \description{ 22 | Calculate confidence intervals 23 | } 24 | \examples{ 25 | estimates <- c(-0.2630303, 1.5788579) 26 | par_list <- list(list(par_name = "par_inv_R0", 27 | par_trans = "expit"), 28 | list(par_name = "I0", 29 | par_trans = "exp")) 30 | hsn <- matrix(c(3513.10521, -493.5469626, 31 | -493.5469626, 88.4871290), ncol = 2) 32 | sd_conf_intervals(estimates, par_list, hsn) 33 | } 34 | -------------------------------------------------------------------------------- /man/sd_interpret_estimates.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interpreters.R 3 | \name{sd_interpret_estimates} 4 | \alias{sd_interpret_estimates} 5 | \title{Interpret estimates} 6 | \usage{ 7 | sd_interpret_estimates(estimates, par_list) 8 | } 9 | \arguments{ 10 | \item{estimates}{A list or data frame} 11 | 12 | \item{par_list}{A list} 13 | } 14 | \value{ 15 | A data frame 16 | } 17 | \description{ 18 | Interpret estimates 19 | } 20 | \examples{ 21 | estimates <- c(par_beta = 0, 22 | par_rho = 0.8472979, 23 | I0 = 0, 24 | inv_phi = -2.302585) 25 | 26 | par_list <- list(list(par_name = "par_beta", 27 | par_trans = "exp"), 28 | list(par_name = "par_rho", 29 | par_trans = "expit"), 30 | list(par_name = "I0", 31 | par_trans = "exp"), 32 | list(par_name = "phi", 33 | par_trans = c("exp", "inv"))) 34 | sd_interpret_estimates(estimates, par_list) 35 | } 36 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 Jair Andrade 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /R/summaries.R: -------------------------------------------------------------------------------- 1 | 2 | #' Summarise the information of a model's constants in a data frame 3 | #' 4 | #' @param mdl A list which is the output from read_xmile. 5 | #' 6 | #' @return A data frame. 7 | #' @export 8 | #' 9 | #' @examples 10 | #' path <- system.file("models", "SIR.stmx", package = "readsdr") 11 | #' mdl <- read_xmile(path) 12 | #' sd_constants(mdl) 13 | sd_constants <- function(mdl) { 14 | consts_list <- lapply(mdl$description$constants, function(const_list) { 15 | data.frame(name = const_list$name, value = const_list$value) 16 | }) 17 | 18 | do.call("rbind", consts_list) 19 | } 20 | 21 | #' Summarise the information of a model's stocks in a data frame 22 | #' 23 | #' @inheritParams sd_constants 24 | #' 25 | #' @return A data frame. 26 | #' @export 27 | #' 28 | #' @examples 29 | #' path <- system.file("models", "SIR.stmx", package = "readsdr") 30 | #' mdl <- read_xmile(path) 31 | #' sd_stocks(mdl) 32 | sd_stocks <- function(mdl) { 33 | lvls_list <- lapply(mdl$description$levels, function(lvl_list) { 34 | data.frame(name = lvl_list$name, init_value = lvl_list$initValue) 35 | }) 36 | do.call("rbind", lvls_list) 37 | } 38 | -------------------------------------------------------------------------------- /man/sd_simulate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulators.R 3 | \name{sd_simulate} 4 | \alias{sd_simulate} 5 | \title{Simulate a System Dynamics model} 6 | \usage{ 7 | sd_simulate( 8 | ds_inputs, 9 | start_time = NULL, 10 | stop_time = NULL, 11 | timestep = NULL, 12 | integ_method = "euler" 13 | ) 14 | } 15 | \arguments{ 16 | \item{ds_inputs}{A list of deSolve inputs generated by read_xmile} 17 | 18 | \item{start_time}{A number indicating the time at which the simulation begins.} 19 | 20 | \item{stop_time}{A number indicating the time at which the simulation ends.} 21 | 22 | \item{timestep}{A number indicating the time interval for the simulation. 23 | Also known as \code{dt}.} 24 | 25 | \item{integ_method}{A string indicating the integration method. It can be 26 | either "euler" or "rk4"} 27 | } 28 | \value{ 29 | a data frame 30 | } 31 | \description{ 32 | Simulate a System Dynamics model 33 | } 34 | \examples{ 35 | path <- system.file("models", "SIR.stmx", package = "readsdr") 36 | ds_inputs <- xmile_to_deSolve(path) 37 | sd_simulate(ds_inputs, 0, 1, 0.25, "rk4") 38 | } 39 | -------------------------------------------------------------------------------- /tests/testthat/test-comparison_operators.R: -------------------------------------------------------------------------------- 1 | context("Translate equal sign") 2 | 3 | test_that("translate_equal_sign() translates equal operator", { 4 | actual_val <- translate_equal_sign('a = b') 5 | expected_val <- 'a == b' 6 | expect_equal(actual_val, expected_val) 7 | }) 8 | 9 | test_that("translate_equal_sign() does not misinterpret greater or equal to", { 10 | actual_val <- translate_equal_sign('a >= b') 11 | expected_val <- 'a >= b' 12 | expect_equal(actual_val, expected_val) 13 | }) 14 | 15 | test_that("translate_equal_sign ignores the correct equal operator", { 16 | actual_val <- translate_equal_sign('a == b') 17 | expected_val <- 'a == b' 18 | expect_equal(actual_val, expected_val) 19 | }) 20 | 21 | test_that("translate_equal_sign ignores the not equal operator", { 22 | actual_val <- translate_equal_sign('a != b') 23 | expected_val <- 'a != b' 24 | expect_equal(actual_val, expected_val) 25 | }) 26 | 27 | context("Translate not equal sign") 28 | 29 | test_that("translate_not_equal_sign() translates the not equal operator", { 30 | actual_val <- translate_not_equal_sign('a <> b') 31 | expected_val <- 'a != b' 32 | expect_equal(actual_val, expected_val) 33 | }) 34 | -------------------------------------------------------------------------------- /tests/testthat/test-stan_postprocessing.R: -------------------------------------------------------------------------------- 1 | test_that("extract_timeseries_var() returns the expected data frame", { 2 | test_df <- data.frame(`var[1]` = rep(0, 2), 3 | `var[2]` = rep(1, 2), 4 | check.names = FALSE) 5 | 6 | expected_df <- data.frame(iter = rep(1:2, 2), 7 | time = rep(1:2, each = 2), 8 | variable = "var", 9 | value = c(0, 0, 1, 1)) 10 | 11 | expect_equal(extract_timeseries_var("var", test_df), expected_df) 12 | 13 | }) 14 | 15 | test_that("extract_timeseries_stock() returns the expected data frame", { 16 | test_df <- data.frame(`yhat[1,2]` = rep(0, 2), 17 | `yhat[2,2]` = rep(1, 2), 18 | check.names = FALSE) 19 | 20 | expected_df <- data.frame(iter = rep(1:2, 2), 21 | time = rep(1:2, each = 2), 22 | stock = "S2", 23 | value = c(0, 0, 1, 1)) 24 | 25 | test_stocks <- c("S1", "S2") 26 | 27 | expect_equal(extract_timeseries_stock("S2", test_df, test_stocks, "yhat"), 28 | expected_df) 29 | }) 30 | -------------------------------------------------------------------------------- /tests/testthat/test-summaries.R: -------------------------------------------------------------------------------- 1 | mdl <- list(description = list( 2 | constants = list( 3 | list(name = "birth_rate", 4 | value = 0.1), 5 | list(name = "death_rate", 6 | value = 0.1) 7 | ), 8 | levels = list( 9 | list(name = "Population", 10 | initValue = 100), 11 | list(name = "Deaths", 12 | initValue = 0) 13 | ))) 14 | 15 | test_that("sd_constants() returns the expected data frame", { 16 | expect_is(sd_constants(mdl), "data.frame") 17 | expect_equal(sd_constants(mdl), 18 | data.frame(name = c("birth_rate", "death_rate"), 19 | value = c(0.1,0.1))) 20 | }) 21 | 22 | test_that("sd_stocks() returns the expected data frame", { 23 | expect_is(sd_stocks(mdl), "data.frame") 24 | expect_equal(sd_stocks(mdl), 25 | data.frame(name = c("Population", "Deaths"), 26 | init_value = c(100, 0))) 27 | 28 | filepath <- system.file("models/", "SIR.stmx", package = "readsdr") 29 | mdl <- read_xmile(filepath) 30 | actual_df <- sd_stocks(mdl) 31 | expected_df <- data.frame(name = "Susceptible", "Infected", "Recovered", 32 | init_value = c(990, 10, 0)) 33 | }) 34 | -------------------------------------------------------------------------------- /man/extract_timeseries_stock.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stan_postprocessing.R 3 | \name{extract_timeseries_stock} 4 | \alias{extract_timeseries_stock} 5 | \title{Extract the values over time of a stock from a Stan fit} 6 | \usage{ 7 | extract_timeseries_stock(stock_name, posterior_df, all_stocks, ODE_output) 8 | } 9 | \arguments{ 10 | \item{stock_name}{A string that indicates the stock's name for which the 11 | function will construct the timeseries.} 12 | 13 | \item{posterior_df}{A Stan fit object converted into a data frame} 14 | 15 | \item{all_stocks}{A vector of strings that contains the names of all the 16 | stocks in the model. This vector must have the same order as the differential 17 | equations in the Stan code.} 18 | 19 | \item{ODE_output}{A string that indicates the name of the variable where 20 | model's output in stored in Stan.} 21 | } 22 | \value{ 23 | A data frame 24 | } 25 | \description{ 26 | Extract the values over time of a stock from a Stan fit 27 | } 28 | \examples{ 29 | posterior_df <- data.frame(`yhat[1,2]` = rep(0, 2), `yhat[2,2]` = rep(1, 2), 30 | check.names = FALSE) 31 | stocks <- c("S1", "S2") 32 | extract_timeseries_stock("S2", posterior_df, stocks, "yhat") 33 | } 34 | -------------------------------------------------------------------------------- /man/sd_impact_inputs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/impact_inputs.R 3 | \name{sd_impact_inputs} 4 | \alias{sd_impact_inputs} 5 | \title{Construct inputs for performing structural analysis via the impact method} 6 | \usage{ 7 | sd_impact_inputs(desc_list) 8 | } 9 | \arguments{ 10 | \item{desc_list}{Element 'description' from the list returned by \code{read_xmile()}} 11 | } 12 | \value{ 13 | A list of three elements. The first element, \code{flows}, is a data 14 | frame that lists all the stock-flow links in the model. Further, this data 15 | frame describes the equation that governs the link and whether the link is 16 | an inflow (+) or an outflow (-). The second element, \code{pathways}, is a 17 | data frame that lists all the pathways among stocks. The third element, 18 | \code{velocities}, is a data frame in which each row corresponds to a 19 | stock. Each row consists of two columns (name & equation). 20 | } 21 | \description{ 22 | Construct inputs for performing structural analysis via the impact method 23 | } 24 | \examples{ 25 | filepath <- system.file("models/", "SIR.stmx", package = "readsdr") 26 | mdl <- read_xmile(filepath) 27 | desc_list <- mdl$description 28 | sd_impact_inputs(desc_list) 29 | } 30 | -------------------------------------------------------------------------------- /R/logical_operators.R: -------------------------------------------------------------------------------- 1 | 2 | translate_logical_operators <- function(equation, vendor) { 3 | equation %>% 4 | translate_AND(vendor) %>% 5 | translate_OR(vendor) %>% 6 | translate_NOT(vendor) 7 | } 8 | 9 | translate_AND <- function(equation, vendor) { 10 | if(vendor == "Vensim") { 11 | equation <- stringr::str_replace_all(equation, ":AND:", "&") 12 | } 13 | 14 | if(vendor == "isee") { 15 | pattern <- stringr::regex("AND(?=\\(.+\\))", ignore_case = TRUE) 16 | equation <- stringr::str_replace_all(equation, pattern, "&") 17 | } 18 | 19 | equation 20 | } 21 | 22 | translate_OR <- function(equation, vendor) { 23 | if(vendor == "Vensim") { 24 | equation <- stringr::str_replace_all(equation, ":OR:", "|") 25 | } 26 | 27 | if(vendor == "isee") { 28 | pattern <- stringr::regex("OR(?=\\(.+\\))", ignore_case = TRUE) 29 | equation <- stringr::str_replace_all(equation , pattern, "|") 30 | } 31 | 32 | equation 33 | } 34 | 35 | translate_NOT <- function(equation, vendor) { 36 | 37 | if(vendor == "Vensim") { 38 | equation <- stringr::str_replace_all(equation, ":NOT:", "!") 39 | } 40 | 41 | if(vendor == "isee") { 42 | pattern <- stringr::regex("NOT(?=\\(.+\\))", ignore_case = TRUE) 43 | equation <- stringr::str_replace_all(equation , pattern, "!") 44 | } 45 | equation 46 | } 47 | -------------------------------------------------------------------------------- /tests/testthat/test-prior_checks.R: -------------------------------------------------------------------------------- 1 | test_that("prior_checks() returns the expected list", { 2 | 3 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 4 | 5 | meas_mdl <- list("y ~ neg_binomial_2(net_flow(C), phi)") 6 | 7 | estimated_params <- list( 8 | sd_prior("par_beta", "lognormal", c(0, 1)), 9 | sd_prior("par_rho", "beta", c(2, 2)), 10 | sd_prior("I0", "lognormal", c(0, 1), "init")) 11 | 12 | set.seed(666) 13 | 14 | actual <- sd_prior_checks(filepath, meas_mdl, estimated_params, n_draws = 2, 15 | start_time = 0, stop_time = 5, 16 | integ_method = "rk4", timestep = 1/32) 17 | 18 | df1 <- data.frame(iter = c(1,2), 19 | par_beta = c(2.124021, 7.495888), 20 | par_rho = c(0.4005852, 0.9374636), 21 | I0 = c(0.1089491, 2.1348496), 22 | inv_phi = c(0.5222716, 0.3047205)) 23 | 24 | df2 <- data.frame(iter = rep(c(1, 2), each = 5), 25 | time = rep(1:5, 2), 26 | var_name = "y", 27 | measurement = c(0, 0, 0, 0, 2, 5, 27, 30, 406, 544)) 28 | 29 | expected <- list(parameters = df1, 30 | measurements = df2) 31 | 32 | expect_equal(actual, expected, tolerance = 1e-7) 33 | }) 34 | -------------------------------------------------------------------------------- /man/xmile_to_deSolve.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read_xmile.R 3 | \name{xmile_to_deSolve} 4 | \alias{xmile_to_deSolve} 5 | \title{Parse XMILE to deSolve components} 6 | \usage{ 7 | xmile_to_deSolve(filepath) 8 | } 9 | \arguments{ 10 | \item{filepath}{A string that indicates a path to a file with extension .stmx 11 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 12 | from Vensim with extension .xmile} 13 | } 14 | \value{ 15 | This function returns a list with at least four elements. 16 | \emph{stocks}, a numeric vector that contains initial values. \emph{consts}, 17 | a numeric vector with the model's constants. \emph{func}, the function that 18 | wraps the model's equations. \emph{sim_params}, a list with control 19 | parameters. If the model includes a table or graphical function, this 20 | function returns the element \emph{graph_funs}, a list with these functions. 21 | } 22 | \description{ 23 | \code{xmile_to_deSolve} returns a list that serves as an input for 24 | deSolve's ODE function. 25 | } 26 | \details{ 27 | This function extracts the xml from the file specified via \code{filepath} 28 | to generate a list with the necessary elements to simulate with 29 | \link[deSolve]{deSolve}. 30 | } 31 | \examples{ 32 | path <- system.file("models", "SIR.stmx", package = "readsdr") 33 | xmile_to_deSolve(path) 34 | } 35 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: readsdr 2 | Type: Package 3 | Title: Translate Models from System Dynamics Software into 'R' 4 | Version: 0.3.0.9001 5 | Authors@R: person("Jair", "Andrade", email = "jair.albert.andrade@gmail.com", 6 | role = c("aut", "cre"), 7 | comment = c(ORCID = "0000-0002-1412-7868")) 8 | Description: The goal of 'readsdr' is to bridge the design capabilities from 9 | specialised System Dynamics software with the powerful numerical tools 10 | offered by 'R' libraries. The package accomplishes this goal by parsing 11 | 'XMILE' files ('Vensim' and 'Stella') models into 'R' objects to construct 12 | networks (graph theory); 'ODE' functions for 'Stan'; and inputs to simulate 13 | via 'deSolve' as described in Duggan (2016) . 14 | License: MIT + file LICENSE 15 | Encoding: UTF-8 16 | LazyData: true 17 | RoxygenNote: 7.3.1 18 | Suggests: 19 | testthat (>= 2.1.0), 20 | igraph, 21 | knitr, 22 | rmarkdown, 23 | ggplot2, 24 | tidyr, 25 | truncnorm 26 | Imports: 27 | stringr, 28 | xml2, 29 | purrr, 30 | dplyr, 31 | rlang, 32 | stringi, 33 | magrittr, 34 | stats, 35 | deSolve, 36 | utils, 37 | future, 38 | future.apply, 39 | progressr 40 | BugReports: https://github.com/jandraor/readsdr/issues 41 | VignetteBuilder: knitr 42 | Depends: 43 | R (>= 4.1.0) 44 | -------------------------------------------------------------------------------- /man/stan_ode_function.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stan_ode_function.R 3 | \name{stan_ode_function} 4 | \alias{stan_ode_function} 5 | \title{Create Stan ODE function} 6 | \usage{ 7 | stan_ode_function( 8 | filepath, 9 | func_name, 10 | pars = NULL, 11 | const_list = NULL, 12 | extra_funs = NULL, 13 | XMILE_structure 14 | ) 15 | } 16 | \arguments{ 17 | \item{filepath}{A string that indicates a path to a file with extension .stmx 18 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 19 | from Vensim with extension .xmile} 20 | 21 | \item{func_name}{A string for naming the ODE function} 22 | 23 | \item{pars}{A character vector that indicates which constants will be 24 | considered as parameters in the ODE function} 25 | 26 | \item{const_list}{A list in which each element's name is the name of the 27 | constant to override and the element's value correspond to the new value.} 28 | 29 | \item{extra_funs}{A vector of strings. Each string corresponds to a 30 | user-defined function.} 31 | 32 | \item{XMILE_structure}{A list.} 33 | } 34 | \value{ 35 | A string with the code containing a function with the model's 36 | equations in the format required by cmdstan 2.24+. 37 | } 38 | \description{ 39 | Create Stan ODE function 40 | } 41 | \examples{ 42 | path <- system.file("models", "SIR.stmx", package = "readsdr") 43 | stan_ode_function(path, "my_model") 44 | } 45 | -------------------------------------------------------------------------------- /tests/testthat/test-Vensim_workarounds.R: -------------------------------------------------------------------------------- 1 | test_that("extract_vars_in_stocks handles DELAY FIXED from Vensim", { 2 | test_xml <- xml2::read_xml(' 3 | 4 | 5 | 6 | 7 | 8 | out= 9 | DELAY_FIXED(inflow, 2, 0) 10 | 11 | 12 | 13 | 14 | 0 15 | 16 | 17 | inflow 18 | 19 | 20 | outflow 21 | 22 | 23 | 24 | 3 + STEP(3, 2) 25 | 26 | 27 | 28 | ') 29 | 30 | stocks_xml <- xml2::xml_find_all(test_xml, ".//d1:stock") 31 | 32 | vars_and_consts <- list( 33 | variables = list( 34 | list(name = "inflow", 35 | equation = "3+ifelse(time>=3,3,0)")), 36 | constants = list(), 37 | builtin_stocks = list()) 38 | 39 | actual_obj <- extract_vars_in_stocks(stocks_xml, vars_and_consts) 40 | 41 | expected_obj <- list( 42 | variables = list( 43 | list(name = "inflow", 44 | equation = "3+ifelse(time>=3,3,0)"), 45 | list(name = "outflow", 46 | equation = "sd_fixed_delay('inflow',time,2,0,.memory)")), 47 | constants = list(), 48 | builtin_stocks = list()) 49 | 50 | expect_equal(actual_obj, expected_obj) 51 | }) 52 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | #' @importFrom magrittr %>% 2 | #' @export 3 | magrittr::`%>%` 4 | 5 | #' @importFrom deSolve timestep 6 | #' @export 7 | deSolve::timestep 8 | 9 | remove_NULL <- function(x.list) { 10 | x.list[unlist(lapply(x.list, length) != 0)] 11 | } 12 | 13 | get_names <- function(obj_list, name_var = "name") { 14 | sapply(obj_list, function(obj) obj[[name_var]]) 15 | } 16 | 17 | get_raw_names <- function(obj_list, name_var) { 18 | 19 | purrr::map_chr(obj_list, function(obj) { 20 | 21 | name <- obj[[name_var]] 22 | 23 | if("par_trans" %in% names(obj)) { 24 | 25 | name <- stringr::str_remove(name, paste0(obj$par_trans, "_")) 26 | } 27 | 28 | name 29 | }) 30 | } 31 | 32 | as_row_list <- function(df) do.call(function(...) Map(list,...), df) 33 | 34 | execute_trans <- function(val, trans_type, return_type = "numeric") { 35 | 36 | if(trans_type == "inv" & return_type == "numeric") return(1/val) 37 | 38 | if(trans_type == "inv" & return_type == "text") return(paste0("1/", val)) 39 | } 40 | 41 | is_string_numeric <- function(x) suppressWarnings(ifelse(!is.na(as.numeric(x)), 42 | TRUE, FALSE)) 43 | 44 | # This function guarantees that consts and auxs have identical properties 45 | format_consts_as_vars <- function(constants) { 46 | 47 | lapply(constants, function(const) { 48 | list(name = const$name, equation = const$value) 49 | }) 50 | } 51 | 52 | df2list <- function(df) do.call(function(...) Map(list,...), df) 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ${{ matrix.config.os }} 14 | 15 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | config: 21 | - {os: macos-latest, r: 'release'} 22 | - {os: windows-latest, r: 'release'} 23 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 24 | - {os: ubuntu-latest, r: 'release'} 25 | - {os: ubuntu-latest, r: 'oldrel-1'} 26 | 27 | env: 28 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 29 | R_KEEP_PKG_SOURCE: yes 30 | 31 | steps: 32 | - uses: actions/checkout@v3 33 | 34 | - uses: r-lib/actions/setup-pandoc@v2 35 | 36 | - uses: r-lib/actions/setup-r@v2 37 | with: 38 | r-version: ${{ matrix.config.r }} 39 | http-user-agent: ${{ matrix.config.http-user-agent }} 40 | use-public-rspm: true 41 | 42 | - uses: r-lib/actions/setup-r-dependencies@v2 43 | with: 44 | extra-packages: any::rcmdcheck 45 | needs: check 46 | 47 | - uses: r-lib/actions/check-r-package@v2 48 | with: 49 | upload-snapshots: true 50 | -------------------------------------------------------------------------------- /tests/testthat/SEIR_C_meas.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[5] dydt; 6 | real S_to_E; 7 | real E_to_I; 8 | real I_to_R; 9 | real C_in; 10 | S_to_E = params[1]*y[1]*y[3]/10000; 11 | E_to_I = 0.5*y[2]; 12 | I_to_R = 0.5*y[3]; 13 | C_in = params[2]*E_to_I; 14 | dydt[1] = -S_to_E; 15 | dydt[2] = S_to_E-E_to_I; 16 | dydt[3] = E_to_I-I_to_R; 17 | dydt[4] = I_to_R; 18 | dydt[5] = C_in; 19 | return dydt; 20 | } 21 | } 22 | data { 23 | int n_obs; 24 | array[n_obs] int y; 25 | array[n_obs] real ts; 26 | } 27 | parameters { 28 | real par_beta; 29 | real par_rho; 30 | real I0; 31 | } 32 | transformed parameters{ 33 | array[n_obs] vector[5] x; // Output from the ODE solver 34 | array[2] real params; 35 | vector[5] x0; // init values 36 | x0[1] = (10000) - I0; // S 37 | x0[2] = 0; // E 38 | x0[3] = I0; // I 39 | x0[4] = 0; // R 40 | x0[5] = I0; // C 41 | params[1] = par_beta; 42 | params[2] = par_rho; 43 | x = ode_rk45(X_model, x0, 0, ts, params); 44 | } 45 | model { 46 | par_beta ~ lognormal(0, 1); 47 | par_rho ~ beta(2, 2); 48 | I0 ~ lognormal(0, 1); 49 | y ~ poisson(x[:, 5]); 50 | } 51 | generated quantities { 52 | real log_lik; 53 | array[n_obs] int sim_y; 54 | log_lik = poisson_lpmf(y | x[:, 5]); 55 | sim_y = poisson_rng(x[:, 5]); 56 | } 57 | -------------------------------------------------------------------------------- /tests/testthat/test-arrange_variables.R: -------------------------------------------------------------------------------- 1 | test_that("arrange_variables() returns variables in computational order", { 2 | 3 | variables <- list( 4 | list(name = "births", 5 | equation = "population*birthRate"), 6 | list(name = "birthRate", 7 | equation = "birthRate2") 8 | ) 9 | 10 | ordered_vars <- arrange_variables(variables) 11 | expected_list <- c(variables[2], variables[1]) 12 | expect_equal(ordered_vars, expected_list) 13 | }) 14 | 15 | test_that("arrange_variables() works when there are duplicated equations", { 16 | 17 | variables <- list( 18 | list(name = "births", 19 | equation = "population*(growth_rate_1+growth_rate_2)"), 20 | list(name = "growth_rate_1", 21 | equation = "growth_rate_base"), 22 | list(name = "growth_rate_2", 23 | equation = "growth_rate_base") 24 | ) 25 | expected_list <- c(variables[2], variables[3], variables[1]) 26 | ordered_vars <- arrange_variables(variables) 27 | expect_equal(ordered_vars, expected_list) 28 | }) 29 | 30 | test_that("arrange_variables() returns an empty list if the input is an empty list", { 31 | variables <- list() 32 | actual_val <- arrange_variables(list()) 33 | expected_val <- list() 34 | expect_equal(actual_val, expected_val) 35 | }) 36 | 37 | test_that("arrange_variables() returns an error should the rhs does not contain variables", { 38 | 39 | test_list <- list(list(name = "c", equation = "a+b"), 40 | list(name = "a", equation = "3")) 41 | 42 | expect_error(arrange_variables(test_list)) 43 | }) 44 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: any::covr 27 | needs: coverage 28 | 29 | - name: Test coverage 30 | run: | 31 | covr::codecov( 32 | quiet = FALSE, 33 | clean = FALSE, 34 | install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") 35 | ) 36 | shell: Rscript {0} 37 | 38 | - name: Show testthat output 39 | if: always() 40 | run: | 41 | ## -------------------------------------------------------------------- 42 | find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true 43 | shell: bash 44 | 45 | - name: Upload test results 46 | if: failure() 47 | uses: actions/upload-artifact@v3 48 | with: 49 | name: coverage-test-failures 50 | path: ${{ runner.temp }}/package 51 | -------------------------------------------------------------------------------- /man/create_stan_function.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/create_stan_function.R 3 | \name{create_stan_function} 4 | \alias{create_stan_function} 5 | \title{Create a Stan's ODE function from an XMILE file} 6 | \usage{ 7 | create_stan_function( 8 | filepath, 9 | func_name, 10 | pars = NULL, 11 | override.consts = NULL, 12 | additional_funs = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{filepath}{A string that indicates a path to a file with extension .stmx 17 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 18 | from Vensim with extension .xmile} 19 | 20 | \item{func_name}{A string for naming the ODE function} 21 | 22 | \item{pars}{A character vector that indicates which constants will be 23 | considered as parameters in the ODE function} 24 | 25 | \item{override.consts}{A list in which each element is a name-value pair that 26 | replaces values of constants.} 27 | 28 | \item{additional_funs}{A vector of strings. Each string corresponds to a 29 | user-defined function.} 30 | } 31 | \value{ 32 | A string with the code containing the model's equations in the 33 | format required by Stan. 34 | } 35 | \description{ 36 | \code{create_stan_function} returns a string with the code for a Stan's ODE function 37 | } 38 | \details{ 39 | This function extracts the xml from the file specified via \code{filepath} to 40 | generate the code for an equivalent model in Stan. 41 | } 42 | \examples{ 43 | path <- system.file("models", "SIR.stmx", package = "readsdr") 44 | create_stan_function(path, "my_model") 45 | } 46 | -------------------------------------------------------------------------------- /tests/testthat/test-what_if_from_time.R: -------------------------------------------------------------------------------- 1 | test_that("sd_what_if_from_time() returns the expected output", { 2 | 3 | filepath <- system.file("models/", "SIR.stmx", package = "readsdr") 4 | mdl <- read_xmile(filepath) 5 | ds_components <- mdl$deSolve_components 6 | output <- sd_what_if_from_time(3, par_list = list(c = 4), 7 | ds_inputs = ds_components, 8 | start_time = 0, stop_time = 5, 9 | integ_method = "rk4", 10 | timestep = 1 / 16) 11 | expect_is(output, "data.frame") 12 | 13 | actual_val <- tail(output[, "Infected"], 1) 14 | expect_equal(actual_val , 253.706683332, tolerance = 1e-9) 15 | }) 16 | 17 | test_that("sd_what_from_time() works with the up_to_time parameter", { 18 | 19 | filepath <- system.file("models/", "SIR.stmx", package = "readsdr") 20 | mdl <- read_xmile(filepath) 21 | ds_components <- mdl$deSolve_components 22 | output <- sd_what_if_from_time(time = 3, up_to_time = 5, 23 | par_list = list(c = 4), 24 | ds_inputs = ds_components, 25 | start_time = 0, stop_time = 10, 26 | integ_method = "rk4", 27 | timestep = 1 / 16) 28 | 29 | expect_is(output, "data.frame") 30 | 31 | actual_val <- tail(output[, "Infected"], 1) 32 | expect_equal(actual_val, 63.4511067818, tolerance = 1e-9) 33 | }) 34 | -------------------------------------------------------------------------------- /R/stan_data.R: -------------------------------------------------------------------------------- 1 | # Stan's data block for ODE models 2 | stan_data <- function(meas_mdl, unk_inits, data_params, data_inits, 3 | n_difeq = NULL, forecast) { 4 | 5 | external_params <- c(data_params, data_inits) 6 | 7 | decl <- " int n_obs;" 8 | 9 | data_decl <- lapply(meas_mdl, construct_data_decl) |> 10 | paste(collapse = "\n") 11 | 12 | final_decl <- " array[n_obs] real ts;" 13 | 14 | body_block <- paste(decl, data_decl, final_decl, sep = "\n") 15 | 16 | if(!unk_inits) { 17 | body_block <- paste(body_block, 18 | stringr::str_glue(" vector[{n_difeq}] x0;"), 19 | sep = "\n") 20 | } 21 | 22 | if(!is.null(external_params)) { 23 | 24 | data_params_lines <- stringr::str_glue(" real {external_params};") |> 25 | paste(collapse = "\n") 26 | 27 | body_block <- paste(body_block, data_params_lines, sep = "\n") 28 | } 29 | 30 | if(forecast) body_block <- paste(body_block, " int n_fcst;", 31 | sep = "\n") 32 | 33 | paste("data {", body_block, "}", sep = "\n") 34 | } 35 | 36 | construct_data_decl <- function(meas_obj) { 37 | 38 | decomposed_meas <- decompose_meas(meas_obj) 39 | lhs <- decomposed_meas$lhs 40 | rhs <- decomposed_meas$rhs 41 | type <- get_dist_type(rhs) 42 | 43 | meas_size <- determine_meas_size(rhs) 44 | 45 | # meas_ipt_ln = measurement input line 46 | 47 | if(meas_size == 1) meas_ipt_ln <- stringr::str_glue(" {type} {lhs};") 48 | 49 | if(meas_size == Inf) meas_ipt_ln <- stringr::str_glue(" array[n_obs] {type} {lhs};") 50 | 51 | meas_ipt_ln 52 | } 53 | -------------------------------------------------------------------------------- /R/stan_params.R: -------------------------------------------------------------------------------- 1 | 2 | stan_params <- function(prior) { 3 | 4 | prior <- sort_estimated_pars(prior) 5 | 6 | parameter_lines <- sapply(prior, build_parameter_line) |> 7 | paste(collapse = "\n") 8 | 9 | paste( 10 | "parameters {", 11 | parameter_lines, 12 | "}", sep = "\n") 13 | } 14 | 15 | sort_estimated_pars <- function(prior) { 16 | 17 | par_names <- get_names(prior, "par_name") 18 | 19 | bound_dependencies <- lapply(prior, \(prior_obj) { 20 | 21 | bounds <- c(prior_obj$min, prior_obj$max) 22 | 23 | eq <- ".placeholder" 24 | 25 | if(is.character(bounds)) eq <- paste(bounds, collapse = "+") 26 | 27 | list(name = prior_obj$par_name, 28 | equation = eq) # For arrange_variables() 29 | }) 30 | 31 | sorted_pars <- arrange_variables(bound_dependencies) |> get_names() 32 | 33 | prior[match(sorted_pars, par_names)] 34 | } 35 | 36 | 37 | build_parameter_line <- function(prior_obj) { 38 | 39 | obj_elems <- names(prior_obj) 40 | 41 | decl <- " real" # declaration 42 | 43 | if(all(c("min", "max") %in% obj_elems)) { 44 | 45 | #bounds 46 | bds <- stringr::str_glue("") 47 | 48 | decl <- paste0(decl, bds) 49 | } 50 | 51 | if("min" %in% obj_elems & !"max" %in% obj_elems) { 52 | bds <- stringr::str_glue("") 53 | 54 | decl <- paste0(decl, bds) 55 | } 56 | 57 | if(!"min" %in% obj_elems & "max" %in% obj_elems) { 58 | bds <- stringr::str_glue("") 59 | 60 | decl <- paste0(decl, bds) 61 | } 62 | 63 | par_name <- prior_obj$par_name 64 | 65 | stringr::str_glue("{decl} {par_name};") 66 | } 67 | -------------------------------------------------------------------------------- /R/xmile_graph_funs.R: -------------------------------------------------------------------------------- 1 | translate_graph_func <- function(gf_xml) { 2 | 3 | ypts_xml <- gf_xml |> xml2::xml_find_first(".//d1:ypts") 4 | 5 | ypts <- xml2::xml_text(ypts_xml) |> 6 | stringr::str_split(",", simplify = TRUE) |> as.vector() |> as.numeric() 7 | 8 | length_y <- length(ypts) 9 | 10 | xpts_xml <- gf_xml |> xml2::xml_find_first(".//d1:xpts") 11 | 12 | if(length(xpts_xml) > 0) { 13 | 14 | x_points <- xml2::xml_text(xpts_xml) |> 15 | stringr::str_split(",", simplify = TRUE) |> as.vector() |> as.numeric() 16 | } else{ 17 | 18 | xscale_xml <- gf_xml |> xml2::xml_find_first(".//d1:xscale") 19 | 20 | x_min <- xml2::xml_attr(xscale_xml, "min") |> as.numeric() 21 | x_max <- xml2::xml_attr(xscale_xml, "max") |> as.numeric() 22 | 23 | x_points <- seq(x_min, x_max, length.out = length_y) 24 | } 25 | 26 | graph_fun <- stats::approxfun( 27 | x = x_points, 28 | y = ypts, 29 | method = "linear", 30 | yleft = ypts[[1]], 31 | yright = ypts[[length_y]]) 32 | } 33 | 34 | translate_Vensim_graph_func <- function(equation){ 35 | match_output <- stringr::str_match( 36 | equation, "WITHLOOKUP\\((\\w+),\\(\\[.+\\],(.+)\\)\\)") 37 | 38 | match_data_points <- match_output[[3]] %>% 39 | stringr::str_match_all("\\((.+?),(.+?)\\),") 40 | 41 | x_points <- match_data_points[[1]][, 2] %>% as.numeric() 42 | y_points <- match_data_points[[1]][, 3] %>% as.numeric() 43 | 44 | graph_fun <- stats::approxfun( 45 | x = x_points, 46 | y = y_points, 47 | method = "linear", 48 | yleft = y_points[[1]], 49 | yright = y_points[[length(y_points)]]) 50 | 51 | list(input = match_output[[2]], 52 | graph_fun = graph_fun) 53 | } 54 | -------------------------------------------------------------------------------- /man/sd_what_if_from_time.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/what_if_from_time.R 3 | \name{sd_what_if_from_time} 4 | \alias{sd_what_if_from_time} 5 | \title{What if from time t we change the value of some parameters} 6 | \usage{ 7 | sd_what_if_from_time( 8 | time, 9 | up_to_time = Inf, 10 | par_list, 11 | ds_inputs, 12 | start_time = NULL, 13 | stop_time = NULL, 14 | timestep = NULL, 15 | integ_method = "euler" 16 | ) 17 | } 18 | \arguments{ 19 | \item{time}{Time at which the parameter values change} 20 | 21 | \item{up_to_time}{Time from which the original values are restored.} 22 | 23 | \item{par_list}{A list that indicates which parameters change from time t. 24 | For instance, if you wanted to change the value of parameter \code{c} to 4, 25 | you would provide the \code{list(c = 4)}} 26 | 27 | \item{ds_inputs}{A list of deSolve inputs generated by read_xmile} 28 | 29 | \item{start_time}{A number indicating the time at which the simulation begins.} 30 | 31 | \item{stop_time}{A number indicating the time at which the simulation ends.} 32 | 33 | \item{timestep}{A number indicating the time interval for the simulation. 34 | Also known as \code{dt}.} 35 | 36 | \item{integ_method}{A string indicating the integration method. It can be 37 | either "euler" or "rk4"} 38 | } 39 | \value{ 40 | A data frame 41 | } 42 | \description{ 43 | What if from time t we change the value of some parameters 44 | } 45 | \examples{ 46 | filepath <- system.file("models/", "SIR.stmx", package = "readsdr") 47 | mdl <- read_xmile(filepath) 48 | ds_components <- mdl$deSolve_components 49 | output <- sd_what_if_from_time(3, Inf, list(c = 4), ds_components) 50 | } 51 | -------------------------------------------------------------------------------- /man/sd_measurements.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulator_measurements.R 3 | \name{sd_measurements} 4 | \alias{sd_measurements} 5 | \title{Generate measurements} 6 | \usage{ 7 | sd_measurements( 8 | n_meas, 9 | meas_model, 10 | ds_inputs, 11 | start_time = NULL, 12 | stop_time = NULL, 13 | timestep = NULL, 14 | integ_method = "euler" 15 | ) 16 | } 17 | \arguments{ 18 | \item{n_meas}{Number of measurements. An integer.} 19 | 20 | \item{meas_model}{Measurement model. A list of strings, in which each string 21 | corresponds to sampling statement in Stan language.} 22 | 23 | \item{ds_inputs}{A list of deSolve inputs generated by read_xmile} 24 | 25 | \item{start_time}{A number indicating the time at which the simulation begins.} 26 | 27 | \item{stop_time}{A number indicating the time at which the simulation ends.} 28 | 29 | \item{timestep}{A number indicating the time interval for the simulation. 30 | Also known as \code{dt}.} 31 | 32 | \item{integ_method}{A string indicating the integration method. It can be 33 | either "euler" or "rk4"} 34 | } 35 | \value{ 36 | A data frame. 37 | } 38 | \description{ 39 | Generate measurements 40 | } 41 | \examples{ 42 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 43 | mdl <- read_xmile(filepath) 44 | 45 | mm1 <- "y ~ poisson(C)" 46 | meas_model <- list(mm1) 47 | 48 | sd_measurements(n_meas = 2, 49 | meas_model = meas_model, 50 | ds_inputs = mdl$deSolve_components, 51 | start_time = 0, 52 | stop_time = 10, 53 | timestep = 1/16, 54 | integ_method = "rk4") 55 | } 56 | -------------------------------------------------------------------------------- /tests/testthat/test_stan_files/SEIR_pois_N.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[5] dydt; 6 | real S_to_E; 7 | real E_to_I; 8 | real I_to_R; 9 | real C_in; 10 | S_to_E = params[1]*y[1]*y[3]/params[3]; 11 | E_to_I = 0.5*y[2]; 12 | I_to_R = 0.5*y[3]; 13 | C_in = params[2]*E_to_I; 14 | dydt[1] = -S_to_E; 15 | dydt[2] = S_to_E-E_to_I; 16 | dydt[3] = E_to_I-I_to_R; 17 | dydt[4] = I_to_R; 18 | dydt[5] = C_in; 19 | return dydt; 20 | } 21 | } 22 | data { 23 | int n_obs; 24 | array[n_obs] int y; 25 | array[n_obs] real ts; 26 | real N; 27 | } 28 | parameters { 29 | real par_beta; 30 | real par_rho; 31 | real I0; 32 | } 33 | transformed parameters{ 34 | array[n_obs] vector[5] x; // Output from the ODE solver 35 | array[3] real params; 36 | vector[5] x0; // init values 37 | array[n_obs] real delta_x_1; 38 | x0[1] = N - I0; // S 39 | x0[2] = 0; // E 40 | x0[3] = I0; // I 41 | x0[4] = 0; // R 42 | x0[5] = I0; // C 43 | params[1] = par_beta; 44 | params[2] = par_rho; 45 | params[3] = N; 46 | x = ode_rk45(X_model, x0, 0, ts, params); 47 | delta_x_1[1] = x[1, 5] - x0[5] + 1e-5; 48 | for (i in 1:n_obs-1) { 49 | delta_x_1[i + 1] = x[i + 1, 5] - x[i, 5] + 1e-5; 50 | } 51 | } 52 | model { 53 | par_beta ~ lognormal(0, 1); 54 | par_rho ~ beta(2, 2); 55 | I0 ~ lognormal(0, 1); 56 | y ~ poisson(delta_x_1); 57 | } 58 | generated quantities { 59 | real log_lik; 60 | array[n_obs] int sim_y; 61 | log_lik = poisson_lpmf(y | delta_x_1); 62 | sim_y = poisson_rng(delta_x_1); 63 | } 64 | -------------------------------------------------------------------------------- /tests/testthat/SEIR_normal.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[5] dydt; 6 | real S_to_E; 7 | real E_to_I; 8 | real I_to_R; 9 | real C_in; 10 | S_to_E = params[1]*y[1]*y[3]/10000; 11 | E_to_I = 0.5*y[2]; 12 | I_to_R = 0.5*y[3]; 13 | C_in = params[2]*E_to_I; 14 | dydt[1] = -S_to_E; 15 | dydt[2] = S_to_E-E_to_I; 16 | dydt[3] = E_to_I-I_to_R; 17 | dydt[4] = I_to_R; 18 | dydt[5] = C_in; 19 | return dydt; 20 | } 21 | } 22 | data { 23 | int n_obs; 24 | array[n_obs] real y; 25 | array[n_obs] real ts; 26 | } 27 | parameters { 28 | real par_beta; 29 | real par_rho; 30 | real I0; 31 | real tau; 32 | } 33 | transformed parameters{ 34 | array[n_obs] vector[5] x; // Output from the ODE solver 35 | array[2] real params; 36 | vector[5] x0; // init values 37 | array[n_obs] real delta_x_1; 38 | x0[1] = (10000) - I0; // S 39 | x0[2] = 0; // E 40 | x0[3] = I0; // I 41 | x0[4] = 0; // R 42 | x0[5] = I0; // C 43 | params[1] = par_beta; 44 | params[2] = par_rho; 45 | x = ode_rk45(X_model, x0, 0, ts, params); 46 | delta_x_1[1] = x[1, 5] - x0[5] + 1e-5; 47 | for (i in 1:n_obs-1) { 48 | delta_x_1[i + 1] = x[i + 1, 5] - x[i, 5] + 1e-5; 49 | } 50 | } 51 | model { 52 | par_beta ~ lognormal(0, 1); 53 | par_rho ~ beta(2, 2); 54 | I0 ~ lognormal(0, 1); 55 | tau ~ exponential(0.2); 56 | y ~ normal(delta_x_1, tau); 57 | } 58 | generated quantities { 59 | real log_lik; 60 | array[n_obs] real sim_y; 61 | log_lik = normal_lpdf(y | delta_x_1, tau); 62 | sim_y = normal_rng(delta_x_1, tau); 63 | } 64 | -------------------------------------------------------------------------------- /tests/testthat/test_stan_files/SEIR_nbin_data_init.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[5] dydt; 6 | real S_to_E; 7 | real E_to_I; 8 | real I_to_R; 9 | real C_in; 10 | S_to_E = params[1]*y[1]*y[3]/10000; 11 | E_to_I = 0.5*y[2]; 12 | I_to_R = 0.5*y[3]; 13 | C_in = params[2]*E_to_I; 14 | dydt[1] = -S_to_E; 15 | dydt[2] = S_to_E-E_to_I; 16 | dydt[3] = E_to_I-I_to_R; 17 | dydt[4] = I_to_R; 18 | dydt[5] = C_in; 19 | return dydt; 20 | } 21 | } 22 | data { 23 | int n_obs; 24 | array[n_obs] int y; 25 | array[n_obs] real ts; 26 | real I0; 27 | } 28 | parameters { 29 | real par_beta; 30 | real par_rho; 31 | real inv_phi; 32 | } 33 | transformed parameters{ 34 | array[n_obs] vector[5] x; // Output from the ODE solver 35 | array[2] real params; 36 | vector[5] x0; // init values 37 | array[n_obs] real delta_x_1; 38 | real phi; 39 | phi = 1 / inv_phi; 40 | x0[1] = (10000) - I0; // S 41 | x0[2] = 0; // E 42 | x0[3] = I0; // I 43 | x0[4] = 0; // R 44 | x0[5] = I0; // C 45 | params[1] = par_beta; 46 | params[2] = par_rho; 47 | x = ode_rk45(X_model, x0, 0, ts, params); 48 | delta_x_1[1] = x[1, 5] - x0[5] + 1e-5; 49 | for (i in 1:n_obs-1) { 50 | delta_x_1[i + 1] = x[i + 1, 5] - x[i, 5] + 1e-5; 51 | } 52 | } 53 | model { 54 | par_beta ~ lognormal(0, 1); 55 | par_rho ~ beta(2, 2); 56 | inv_phi ~ exponential(5); 57 | y ~ neg_binomial_2(delta_x_1, phi); 58 | } 59 | generated quantities { 60 | real log_lik; 61 | array[n_obs] int sim_y; 62 | log_lik = neg_binomial_2_lpmf(y | delta_x_1, phi); 63 | sim_y = neg_binomial_2_rng(delta_x_1, phi); 64 | } 65 | -------------------------------------------------------------------------------- /man/sd_data_generator_fun.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SBC.R 3 | \name{sd_data_generator_fun} 4 | \alias{sd_data_generator_fun} 5 | \title{Function factory for SBC} 6 | \usage{ 7 | sd_data_generator_fun( 8 | filepath, 9 | estimated_params, 10 | meas_mdl, 11 | start_time = NULL, 12 | stop_time = NULL, 13 | timestep = NULL, 14 | integ_method = "euler" 15 | ) 16 | } 17 | \arguments{ 18 | \item{filepath}{A string that indicates a path to a file with extension .stmx 19 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 20 | from Vensim with extension .xmile} 21 | 22 | \item{estimated_params}{A list of lists. Each sublist describes each 23 | parameter that will be estimated in the inference stage. To construct this 24 | description, the user can avail of the function `sd_prior`.} 25 | 26 | \item{meas_mdl}{A list of strings. Each string corresponds to a sampling 27 | statement written in Stan language.} 28 | 29 | \item{start_time}{A number indicating the time at which the simulation begins.} 30 | 31 | \item{stop_time}{A number indicating the time at which the simulation ends.} 32 | 33 | \item{timestep}{A number indicating the time interval for the simulation. 34 | Also known as \code{dt}.} 35 | 36 | \item{integ_method}{A string indicating the integration method. It can be 37 | either "euler" or "rk4"} 38 | } 39 | \value{ 40 | A function. 41 | } 42 | \description{ 43 | Function factory for SBC 44 | } 45 | \examples{ 46 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 47 | meas_mdl <- list("y ~ poisson(net_flow(C))") 48 | estimated_params <- list( 49 | sd_prior("par_beta", "lognormal", c(0, 1)), 50 | sd_prior("par_rho", "beta", c(2, 2)), 51 | sd_prior("I0", "lognormal", c(0, 1), "init")) 52 | sd_data_generator_fun(filepath, estimated_params, meas_mdl) 53 | } 54 | -------------------------------------------------------------------------------- /tests/testthat/SEIR_nbinom.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[5] dydt; 6 | real S_to_E; 7 | real E_to_I; 8 | real I_to_R; 9 | real C_in; 10 | S_to_E = params[1]*y[1]*y[3]/10000; 11 | E_to_I = 0.5*y[2]; 12 | I_to_R = 0.5*y[3]; 13 | C_in = params[2]*E_to_I; 14 | dydt[1] = -S_to_E; 15 | dydt[2] = S_to_E-E_to_I; 16 | dydt[3] = E_to_I-I_to_R; 17 | dydt[4] = I_to_R; 18 | dydt[5] = C_in; 19 | return dydt; 20 | } 21 | } 22 | data { 23 | int n_obs; 24 | array[n_obs] int y; 25 | array[n_obs] real ts; 26 | } 27 | parameters { 28 | real par_beta; 29 | real par_rho; 30 | real I0; 31 | real inv_phi; 32 | } 33 | transformed parameters{ 34 | array[n_obs] vector[5] x; // Output from the ODE solver 35 | array[2] real params; 36 | vector[5] x0; // init values 37 | array[n_obs] real delta_x_1; 38 | real phi; 39 | phi = 1 / inv_phi; 40 | x0[1] = (10000) - I0; // S 41 | x0[2] = 0; // E 42 | x0[3] = I0; // I 43 | x0[4] = 0; // R 44 | x0[5] = I0; // C 45 | params[1] = par_beta; 46 | params[2] = par_rho; 47 | x = ode_rk45(X_model, x0, 0, ts, params); 48 | delta_x_1[1] = x[1, 5] - x0[5] + 1e-5; 49 | for (i in 1:n_obs-1) { 50 | delta_x_1[i + 1] = x[i + 1, 5] - x[i, 5] + 1e-5; 51 | } 52 | } 53 | model { 54 | par_beta ~ lognormal(0, 1); 55 | par_rho ~ beta(2, 2); 56 | I0 ~ lognormal(0, 1); 57 | inv_phi ~ exponential(5); 58 | y ~ neg_binomial_2(delta_x_1, phi); 59 | } 60 | generated quantities { 61 | real log_lik; 62 | array[n_obs] int sim_y; 63 | log_lik = neg_binomial_2_lpmf(y | delta_x_1, phi); 64 | sim_y = neg_binomial_2_rng(delta_x_1, phi); 65 | } 66 | -------------------------------------------------------------------------------- /tests/testthat/test-arrays.R: -------------------------------------------------------------------------------- 1 | test_that("array_equations() returns the expected list", { 2 | 3 | dims_obj <- list(global_dims = list(Age = c("1", "2")), 4 | dictionary = list(I = c("Age"))) 5 | 6 | vendor <- "isee" 7 | dim_names <- "Age" 8 | 9 | aux_obj <- list(name = "I_to_R", 10 | equation = "par_gamma*I") 11 | 12 | actual <- array_equations(aux_obj, dims_obj, dim_names, vendor) 13 | 14 | expected <- list(equations = c("par_gamma*I_1", "par_gamma*I_2"), 15 | are_const = c(FALSE, FALSE), 16 | elems = c("1", "2")) 17 | 18 | expect_equal(actual, expected) 19 | 20 | dims_obj <- list(global_dims = list(Age = 1:2), 21 | dictionary = list(lambda = "Age", 22 | S = "Age")) 23 | 24 | aux_obj <- list(name = "S_to_I", 25 | equation = "lambda*S") 26 | 27 | actual <- array_equations(aux_obj, dims_obj, dim_names, vendor) 28 | 29 | expected <- list(equations = c("lambda_1*S_1", "lambda_2*S_2"), 30 | are_const = c(FALSE, FALSE), 31 | elems = c("1", "2")) 32 | 33 | expect_equal(actual, expected) 34 | }) 35 | 36 | test_that("devectorise_equation() returns the expected output", { 37 | 38 | dims_list <- list(Region = c("Westeros", "Essos"), 39 | Age = c("Young", "Old")) 40 | 41 | raw_equation <- "Population[Region,Age] * growth_rate[Region,Age]" 42 | actual <- devectorise_equation(raw_equation, dims_list) 43 | 44 | expected <- c("Population_Westeros_Young * growth_rate_Westeros_Young", 45 | "Population_Westeros_Old * growth_rate_Westeros_Old", 46 | "Population_Essos_Young * growth_rate_Essos_Young", 47 | "Population_Essos_Old * growth_rate_Essos_Old") 48 | 49 | expect_equal(actual, expected) 50 | }) 51 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # readsdr (development version) 2 | 3 | ## New features 4 | 5 | * Support the translation of *EXP* 6 | 7 | # readsdr 0.3.0 8 | 9 | ## Breaking changes 10 | 11 | * Deprecate **stan_data()** & **stan_transformed_data()**. 12 | 13 | ## New features 14 | 15 | * Add Maryland data. 16 | 17 | * Add **sd_posterior_fun()**. 18 | 19 | * Add **sd_Bayes()**. 20 | 21 | * Support the translation of Vensim's *DELAY_N*. 22 | 23 | * Support the translation of Stella's *DELAYN* with four parameters. 24 | 25 | * Add **sd_measurements()**. 26 | 27 | * Support the translation of *RANDOM NORMAL* from Vensim. 28 | 29 | * Add support to bidimensional vectors in Vensim. 30 | 31 | * *read_xmile()* now translates Vensim's *DELAY FIXED*. 32 | 33 | * Add **sd_what_if_from_time()** 34 | 35 | * Add **sd_impact_inputs()** 36 | 37 | * Add **sd_loglik_fun()** 38 | 39 | * Add **sd_net_change()** 40 | 41 | ## Minor improvements and fixes 42 | 43 | * Fix bug in the translation of graphical functions. 44 | 45 | * Parallelisation of *sd_sensitivity_run()* supported in Windows. 46 | 47 | * Support Stella's *apply all* for uni-dimensional vectors. 48 | 49 | * *read_xmile()* returns the element graph only if the argument *graph* is set to *TRUE*. 50 | 51 | * Fix bug (incorrect division due to missing parentheses) in the translation of *SMOOTH*. 52 | 53 | # readsdr 0.2.0 54 | 55 | * Add support to translation of SMOOTH functions from Vensim & Stella. 56 | * Add sd_sensitivity_run(). This function supports parallelisation in 57 | Unix-based systems. 58 | * Add flexibility to read_xmile() by allowing the user to override values of 59 | constants and initial values of stocks. 60 | * Add sd_constants() and sd_stocks() to summarise model's information in data frames. 61 | * Add stan_ode_function() 62 | * Add stan_data() 63 | * Add support to unidimensional vectors in Stella. 64 | * Support the translation of the following math functions: ABS & SQRT. 65 | -------------------------------------------------------------------------------- /R/Vensim_workarounds.R: -------------------------------------------------------------------------------- 1 | extract_vars_in_stocks <- function(stocks_xml, vars_and_consts, inits_vector) { 2 | 3 | vars <- vars_and_consts$variables 4 | consts <- vars_and_consts$constants 5 | b_stocks <- vars_and_consts$builtin_stocks 6 | new_elems <- lapply(stocks_xml, extract_delay_vars, consts, inits_vector) %>% 7 | remove_NULL() 8 | 9 | new_vars <- purrr::map(new_elems, "variable_list") %>% 10 | unlist(recursive = FALSE) 11 | 12 | if(length(new_vars) > 0) vars <- c(vars, new_vars) 13 | 14 | new_stocks <- purrr::map(new_elems, "stock_list") %>% 15 | unlist(recursive = FALSE) 16 | 17 | if(length(new_stocks) > 0) b_stocks <- c(b_stocks, new_stocks) 18 | 19 | vars_and_consts$variables <- vars 20 | vars_and_consts$builtin_stocks <- b_stocks 21 | 22 | vars_and_consts 23 | } 24 | 25 | extract_delay_vars <- function(stock_xml, consts, inits_vector) { 26 | 27 | delay_vars <- list(variable_list = NULL, 28 | stock_list = NULL) 29 | 30 | eq <- xml2::xml_find_all(stock_xml, ".//d1:eqn") %>% xml2::xml_text() 31 | 32 | if(grepl("\\bDELAY_FIXED\\b", eq)) { 33 | 34 | var_name <- stock_xml %>% xml2::xml_attr("name") %>% 35 | sanitise_elem_name() %>% check_elem_name() 36 | 37 | eq <- sanitise_aux_equation(eq, "Vensim") 38 | 39 | var_list <- list(list(name = var_name, 40 | equation = translate_delay(eq, "Vensim"))) 41 | 42 | delay_vars$variable_list <- var_list 43 | 44 | return(delay_vars) 45 | } 46 | 47 | stl_delayn <- stringr::str_detect(eq, "\\bDELAY_N\\b") 48 | 49 | if(stl_delayn) { 50 | 51 | var_name <- stock_xml %>% xml2::xml_attr("name") %>% 52 | sanitise_elem_name() %>% check_elem_name() 53 | 54 | DELAYN_translation <- translate_DELAYN(var_name, eq, "Vensim", consts, 55 | inits_vector) 56 | 57 | return(DELAYN_translation) 58 | } 59 | 60 | NULL 61 | } 62 | -------------------------------------------------------------------------------- /tests/testthat/SEIR_nbinom_data_param.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[5] dydt; 6 | real S_to_E; 7 | real E_to_I; 8 | real I_to_R; 9 | real C_in; 10 | S_to_E = params[1]*y[1]*y[3]/10000; 11 | E_to_I = 0.5*y[2]; 12 | I_to_R = params[3]*y[3]; 13 | C_in = params[2]*E_to_I; 14 | dydt[1] = -S_to_E; 15 | dydt[2] = S_to_E-E_to_I; 16 | dydt[3] = E_to_I-I_to_R; 17 | dydt[4] = I_to_R; 18 | dydt[5] = C_in; 19 | return dydt; 20 | } 21 | } 22 | data { 23 | int n_obs; 24 | array[n_obs] int y; 25 | array[n_obs] real ts; 26 | real par_gamma; 27 | } 28 | parameters { 29 | real par_beta; 30 | real par_rho; 31 | real I0; 32 | real inv_phi; 33 | } 34 | transformed parameters{ 35 | array[n_obs] vector[5] x; // Output from the ODE solver 36 | array[3] real params; 37 | vector[5] x0; // init values 38 | array[n_obs] real delta_x_1; 39 | real phi; 40 | phi = 1 / inv_phi; 41 | x0[1] = (10000) - I0; // S 42 | x0[2] = 0; // E 43 | x0[3] = I0; // I 44 | x0[4] = 0; // R 45 | x0[5] = I0; // C 46 | params[1] = par_beta; 47 | params[2] = par_rho; 48 | params[3] = par_gamma; 49 | x = ode_rk45(X_model, x0, 0, ts, params); 50 | delta_x_1[1] = x[1, 5] - x0[5] + 1e-5; 51 | for (i in 1:n_obs-1) { 52 | delta_x_1[i + 1] = x[i + 1, 5] - x[i, 5] + 1e-5; 53 | } 54 | } 55 | model { 56 | par_beta ~ lognormal(0, 1); 57 | par_rho ~ beta(2, 2); 58 | I0 ~ lognormal(0, 1); 59 | inv_phi ~ exponential(5); 60 | y ~ neg_binomial_2(delta_x_1, phi); 61 | } 62 | generated quantities { 63 | real log_lik; 64 | array[n_obs] int sim_y; 65 | log_lik = neg_binomial_2_lpmf(y | delta_x_1, phi); 66 | sim_y = neg_binomial_2_rng(delta_x_1, phi); 67 | } 68 | -------------------------------------------------------------------------------- /tests/testthat/2d_pop.xmile: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | Vensim 5 | Ventana Systems, Inc. 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 |
15 | 16 | 0 17 | 100 18 |
1
19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | init_pop[Region,Age] 42 | 43 | 44 | Net growth 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | Population[Region,Age] * Growth_rate[Region,Age] 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 0.01,0.1;0.05,0.05; 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 80,20;50,50; 74 | 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /R/extract_variables.R: -------------------------------------------------------------------------------- 1 | #' Extract variables from an equation 2 | #' 3 | #' \code{extract_variables} returns the unique elements in an equation. 4 | #' 5 | #' This function assumes an expression in the canonical form \code{y = f(x)}, 6 | #' where x is a vector of n elements. \code{extract_variables} identify all 7 | #' arguments in \code{f}. This is how it should be used: 8 | #' 9 | #' #' lhs <- "z" 10 | #' rhs <- "x ^ 2 + 2 * x * y + y ^ 2" 11 | #' extract_variables(lhs, rhs) 12 | #' 13 | #' 14 | #' @param lhs A string with the name of the equation's subject, represented by 15 | #' \code{y} in the canonical form. 16 | #' @param rhs The equation or expression for the equation's subject, represented 17 | #' by \code{f(x)} in the canonical form. 18 | #' 19 | #' @return A character vector with the unique elements in the \code{rhs} 20 | #' @noRd 21 | 22 | extract_variables <- function(lhs, rhs) { 23 | 24 | rhs <- stringr::str_replace(rhs, "\\.memory", "") 25 | 26 | raw_elements <- stringr::str_split(rhs, "\\b")[[1]] %>% 27 | stringi::stri_remove_empty() 28 | 29 | # Elements that start with alphabetical characters 30 | elems_alpha <- raw_elements[stringr::str_detect(raw_elements, "^[A-Za-z].*")] 31 | 32 | # Filtering out functions min & max 33 | detected_vars <- stringr::str_remove_all(elems_alpha, "\\bmin\\b|\\bmax\\b") 34 | detected_vars <- detected_vars[detected_vars != ""] 35 | 36 | # Filtering out graph functions 37 | potential_gf <- paste0("f_", lhs) 38 | detected_vars <- detected_vars[detected_vars != potential_gf] 39 | 40 | # Filtering out ifelse 41 | detected_vars <- detected_vars[detected_vars != "ifelse"] 42 | 43 | # Filtering out fixed delay 44 | detected_vars <- detected_vars[detected_vars != "sd_fixed_delay"] 45 | 46 | # Filtering out words reserved for RNG 47 | detected_vars <- detected_vars[!detected_vars %in% c("rnorm", "rtruncnorm", 48 | "truncnorm")] 49 | 50 | unique(detected_vars) 51 | } 52 | -------------------------------------------------------------------------------- /man/read_xmile.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read_xmile.R 3 | \name{read_xmile} 4 | \alias{read_xmile} 5 | \title{Read an XMILE file into R} 6 | \usage{ 7 | read_xmile(filepath, stock_list = NULL, const_list = NULL, graph = FALSE) 8 | } 9 | \arguments{ 10 | \item{filepath}{A string that indicates a path to a file with extension .stmx 11 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 12 | from Vensim with extension .xmile} 13 | 14 | \item{stock_list}{A list in which each element's name is the name of the 15 | stock to override and the element's value correspond to the new init value.} 16 | 17 | \item{const_list}{A list in which each element's name is the name of the 18 | constant to override and the element's value correspond to the new value.} 19 | 20 | \item{graph}{A boolean parameter that indicates whether \code{read_xmile} 21 | returns a graph for the model.} 22 | } 23 | \value{ 24 | This function returns a list with three elements. The first element, 25 | \emph{description}, is a list that contains the simulation parameters, and 26 | the names and equations (including graphical functions) for each stock or 27 | level, variable and constant. The second element, \emph{deSolve_components}, 28 | is a list that contains initial values, constants and the function for 29 | simulating via deSolve. The third element (optional), \emph{igraph} contains 30 | the data.frames for creating a graph with igraph. 31 | } 32 | \description{ 33 | \code{read_xmile} returns a list for constructing deSolve functions and graphs 34 | } 35 | \details{ 36 | This function extracts the xml from the file specified via \code{filepath} 37 | to generate a list of objects. Such a list contains a summary of the model, 38 | the inputs for simulating through \link[deSolve]{deSolve}, and the inputs for 39 | creating a \link[igraph]{igraph} object. 40 | } 41 | \examples{ 42 | path <- system.file("models", "SIR.stmx", package = "readsdr") 43 | read_xmile(path) 44 | } 45 | -------------------------------------------------------------------------------- /man/sd_prior_checks.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prior_checks.R 3 | \name{sd_prior_checks} 4 | \alias{sd_prior_checks} 5 | \title{Prior predictive checks} 6 | \usage{ 7 | sd_prior_checks( 8 | filepath, 9 | meas_mdl, 10 | estimated_params, 11 | n_draws, 12 | start_time = NULL, 13 | stop_time = NULL, 14 | timestep = NULL, 15 | integ_method = "euler" 16 | ) 17 | } 18 | \arguments{ 19 | \item{filepath}{A string that indicates a path to a file with extension .stmx 20 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 21 | from Vensim with extension .xmile} 22 | 23 | \item{meas_mdl}{A list of strings. Each string corresponds to a sampling 24 | statement written in Stan language.} 25 | 26 | \item{estimated_params}{A list of lists. Each sublist describes each 27 | parameter that will be estimated in the inference stage. To construct this 28 | description, the user can avail of the function `sd_prior`.} 29 | 30 | \item{n_draws}{An integer that indicates how many time-series will be 31 | returned.} 32 | 33 | \item{start_time}{A number indicating the time at which the simulation begins.} 34 | 35 | \item{stop_time}{A number indicating the time at which the simulation ends.} 36 | 37 | \item{timestep}{A number indicating the time interval for the simulation. 38 | Also known as \code{dt}.} 39 | 40 | \item{integ_method}{A string indicating the integration method. It can be 41 | either "euler" or "rk4"} 42 | } 43 | \value{ 44 | A list of two data frames. 45 | } 46 | \description{ 47 | Prior predictive checks 48 | } 49 | \examples{ 50 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 51 | meas_mdl <- list("y ~ neg_binomial_2(net_flow(C), phi)") 52 | estimated_params <- list( 53 | sd_prior("par_beta", "lognormal", c(0, 1)), 54 | sd_prior("par_rho", "beta", c(2, 2)), 55 | sd_prior("I0", "lognormal", c(0, 1), "init")) 56 | sd_prior_checks(filepath, meas_mdl, estimated_params, n_draws = 2, 57 | start_time = 0, stop_time = 5, 58 | integ_method = "rk4", timestep = 1/32) 59 | } 60 | -------------------------------------------------------------------------------- /tests/testthat/test-interpreters.R: -------------------------------------------------------------------------------- 1 | test_that("sd_interpret_estimates() returns the expected data frame", { 2 | 3 | estimates <- c(par_beta = 0, 4 | par_rho = 0.8472979, 5 | I0 = 0, 6 | inv_phi = -2.3025855) 7 | 8 | par_list <- list(list(par_name = "par_beta", 9 | par_trans = "exp"), 10 | list(par_name = "par_rho", 11 | par_trans = "expit"), 12 | list(par_name = "I0", 13 | par_trans = "exp"), 14 | list(par_name = "phi", 15 | par_trans = c("exp", "inv"))) 16 | 17 | actual <- sd_interpret_estimates(estimates, par_list) 18 | 19 | expected <- data.frame(par_beta = 1, par_rho = 0.7, I0 = 1, phi = 10) 20 | 21 | expect_equal(actual, expected, tol = 1e-4) 22 | 23 | 24 | estimates <- data.frame(c(0, 0.6931472), 25 | c(0.8472979, 0.8472979), 26 | c(0, 0.4054651), 27 | c(-2.3025855, -2.3025855)) 28 | 29 | actual <- sd_interpret_estimates(estimates, par_list) 30 | 31 | expected <- data.frame(par_beta = c(1, 2), 32 | par_rho = 0.7, 33 | I0 = c(1, 1.5), 34 | phi = 10) 35 | 36 | expect_equal(actual, expected, tol = 1e-4) 37 | }) 38 | 39 | test_that("sd_conf_intervals returns the expected data frame", { 40 | 41 | estimates <- c(-0.2630303135, 1.5788579359) 42 | 43 | par_list <- list(list(par_name = "par_inv_R0", 44 | par_trans = "expit"), 45 | list(par_name = "I0", 46 | par_trans = "exp")) 47 | 48 | hsn <- matrix(c(3513.105214, -493.5469626, -493.5469626, 88.48712899), 49 | ncol = 2) 50 | 51 | actual <- sd_conf_intervals(estimates, par_list, hsn) 52 | 53 | expected <- data.frame(X1 = c("par_inv_R0", "I0"), 54 | X2 = c(0.4172404, 3.0986791), 55 | X3 = c(0.4521597, 7.5893045)) 56 | 57 | names(expected) <- c("parameter", "2.5%", "97.5%") 58 | 59 | expect_equal(actual, expected) 60 | }) 61 | -------------------------------------------------------------------------------- /tests/testthat/test-stan_params.R: -------------------------------------------------------------------------------- 1 | #------------------stan_params()------------------------------------------------ 2 | 3 | test_that("stan_params() returns the expected string", { 4 | 5 | prior <- list(sd_prior("par_beta", "lognormal", c(0, 1)), 6 | sd_prior("par_rho", "beta", c(2, 2)), 7 | sd_prior("I0", "lognormal", c(0, 1), "init")) 8 | 9 | actual <- stan_params(prior) 10 | 11 | expected <- paste( 12 | "parameters {", 13 | " real par_beta;", 14 | " real par_rho;", 15 | " real I0;", 16 | "}", sep = "\n") 17 | 18 | expect_equal(actual, expected) 19 | }) 20 | 21 | test_that("stan_params() allows constraining parameters based on the prior", { 22 | 23 | actual <- stan_params(list(list(par_name = "par_alpha", 24 | dist = "normal", 25 | mu = 0, 26 | sigma = 1, 27 | type = "constant", 28 | min = 0))) 29 | 30 | expected <- paste( 31 | "parameters {", 32 | " real par_alpha;", 33 | "}", sep = "\n") 34 | 35 | expect_equal(actual, expected) 36 | }) 37 | 38 | test_that("stan_params() allows constraining parameters based on other parameters", { 39 | 40 | prior_list <- list(sd_prior("par_alpha", "beta", c(2, 2)), 41 | sd_prior("par_beta", "beta", c(2, 2), max = "par_alpha")) 42 | 43 | actual <- stan_params(prior_list) 44 | 45 | expected <- paste( 46 | "parameters {", 47 | " real par_alpha;", 48 | " real par_beta;", 49 | "}", sep = "\n") 50 | 51 | expect_equal(actual, expected) 52 | 53 | # Test 2 54 | 55 | prior_list <- list(sd_prior("par_beta", "beta", c(2, 2), max = "par_alpha"), 56 | sd_prior("par_alpha", "beta", c(2, 2))) 57 | 58 | actual <- stan_params(prior_list) 59 | 60 | expected <- paste( 61 | "parameters {", 62 | " real par_alpha;", 63 | " real par_beta;", 64 | "}", sep = "\n") 65 | 66 | expect_equal(actual, expected) 67 | }) 68 | -------------------------------------------------------------------------------- /man/sd_prior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/priors.R 3 | \name{sd_prior} 4 | \alias{sd_prior} 5 | \title{Specify priors for the estimated parameters.} 6 | \usage{ 7 | sd_prior(par_name, dist, dist_pars, type = "constant", min = NULL, max = NULL) 8 | } 9 | \arguments{ 10 | \item{par_name}{A string indicating the name of the estimated parameter.} 11 | 12 | \item{dist}{A string indicating the name of the prior distribution. This name 13 | should be consistent with Stan language. For instance, "normal" indicates 14 | the normal distribution in Stan language.} 15 | 16 | \item{dist_pars}{A numeric vector. For instance, if \code{dist} = "normal", 17 | then \code{dist_pars} will be a vector of size 2 corresponding to 18 | the \emph{location} (mean) and \emph{scale} (standard deviation).} 19 | 20 | \item{type}{A string. It can be either 'constant' or 'init'. It is 'constant' 21 | by default. 'init' refers to parameters that have only affect the model at 22 | time 0.} 23 | 24 | \item{min}{An optional numeric or a string value indicating the estimated 25 | parameter's lower bound. This value overrides the inferred bound from the 26 | prior distribution. For instance, specifying a beta distribution for the 27 | estimated parameter inherently sets the lower bound to 0. Providing a 28 | value to \code{min} will override this default with the supplied value. If 29 | the supplied value is a string, it should be the name of another estimated 30 | parameter.} 31 | 32 | \item{max}{An optional numeric value or a string indicating the estimated 33 | parameter's upper bound. This value overrides the inferred bound from the 34 | prior distribution. For instance, specifying a beta distribution for the 35 | estimated parameter inherently sets the upper bound to \code{1}. Providing 36 | a value to \code{max} will override this default with the supplied value. 37 | If the supplied value is a string, it should be the name of another 38 | estimated parameter.} 39 | } 40 | \value{ 41 | A list 42 | } 43 | \description{ 44 | \code{sd_prior} returns a list characterising the features of the prior. 45 | } 46 | \examples{ 47 | sd_prior("par_beta", "lognormal", c(0, 1)) 48 | sd_prior("par_rho", "normal", c(0, 1), min = 0) 49 | } 50 | -------------------------------------------------------------------------------- /man/sd_posterior_fun.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/posterior_fun.R 3 | \name{sd_posterior_fun} 4 | \alias{sd_posterior_fun} 5 | \title{Posterior function} 6 | \usage{ 7 | sd_posterior_fun( 8 | filepath, 9 | meas_data_mdl, 10 | estimated_params, 11 | start_time = NULL, 12 | stop_time = NULL, 13 | timestep = NULL, 14 | integ_method = "euler", 15 | const_list = NULL 16 | ) 17 | } 18 | \arguments{ 19 | \item{filepath}{A string that indicates a path to a file with extension .stmx 20 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 21 | from Vensim with extension .xmile} 22 | 23 | \item{meas_data_mdl}{A list of lists. Each second-level list corresponds to 24 | a sampling statement along with its measurements. Here is an example: \cr 25 | \code{list(formula = "y ~ neg_binomial_2(net_flow(C), phi)", 26 | measurements = 1:10))}} 27 | 28 | \item{estimated_params}{A list of lists. Each sublist describes each 29 | parameter that will be estimated in the inference stage. To construct this 30 | description, the user can avail of the function `sd_prior`.} 31 | 32 | \item{start_time}{A number indicating the time at which the simulation begins.} 33 | 34 | \item{stop_time}{A number indicating the time at which the simulation ends.} 35 | 36 | \item{timestep}{A number indicating the time interval for the simulation. 37 | Also known as \code{dt}.} 38 | 39 | \item{integ_method}{A string indicating the integration method. It can be 40 | either "euler" or "rk4"} 41 | 42 | \item{const_list}{A list in which each element's name is the name of the 43 | constant to override and the element's value correspond to the new value.} 44 | } 45 | \value{ 46 | A function 47 | } 48 | \description{ 49 | Posterior function 50 | } 51 | \examples{ 52 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 53 | meas_data_mdl <- list(list(formula = "y ~ neg_binomial_2(net_flow(C), phi)", 54 | measurements = 1:10)) 55 | estimated_params <- list( 56 | sd_prior("par_beta", "lognormal", c(0, 1)), 57 | sd_prior("par_rho", "beta", c(2, 2)), 58 | sd_prior("I0", "lognormal", c(0, 1), "init")) 59 | fun <- sd_posterior_fun(filepath, meas_data_mdl, estimated_params) 60 | } 61 | -------------------------------------------------------------------------------- /tests/testthat/test-stan_data.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("stan_data() returns the expected string", { 3 | 4 | mm1 <- "y ~ neg_binomial_2(net_flow(C), phi)" 5 | meas_mdl <- list(mm1) 6 | 7 | expected_string <- paste( 8 | "data {", 9 | " int n_obs;", 10 | " array[n_obs] int y;", 11 | " array[n_obs] real ts;", 12 | "}", sep = "\n") 13 | 14 | expect_equal(stan_data(meas_mdl, TRUE, NULL, NULL, 15 | forecast = FALSE), expected_string) 16 | 17 | }) 18 | 19 | test_that("stan_data() declares the vector for init values", { 20 | 21 | mm1 <- "y ~ neg_binomial_2(net_flow(C), phi)" 22 | meas_mdl <- list(mm1) 23 | 24 | expected_string <- paste( 25 | "data {", 26 | " int n_obs;", 27 | " array[n_obs] int y;", 28 | " array[n_obs] real ts;", 29 | " vector[5] x0;", 30 | "}", sep = "\n") 31 | 32 | expect_equal(stan_data(meas_mdl, FALSE, NULL, NULL, 5, 33 | forecast = FALSE), 34 | expected_string) 35 | }) 36 | 37 | test_that("stan_data() handles single measurements", { 38 | 39 | meas_mdl <- list("y ~ lognormal(log(Hares), sigma_1)", 40 | "z ~ lognormal(log(Lynx), sigma_2)", 41 | "y0 ~ lognormal(log(Hares[0]), sigma_1)") 42 | 43 | actual <- stan_data(meas_mdl, TRUE, NULL, NULL, 44 | forecast = FALSE) 45 | 46 | expected <- paste( 47 | "data {", 48 | " int n_obs;", 49 | " array[n_obs] real y;", 50 | " array[n_obs] real z;", 51 | " real y0;", 52 | " array[n_obs] real ts;", 53 | "}", sep = "\n") 54 | 55 | expect_equal(actual, expected) 56 | }) 57 | 58 | # construct_data_decl()--------------------------------------------------------- 59 | 60 | test_that("construct_data_decl() returns the expected string", { 61 | 62 | meas_obj <- "y ~ neg_binomial_2(net_flow(C), phi)" 63 | actual <- construct_data_decl(meas_obj) 64 | expected <- " array[n_obs] int y;" 65 | 66 | expect_equal(actual, expected) 67 | }) 68 | 69 | test_that("construct_data_decl() handles single measurement", { 70 | 71 | meas_obj <- "y0 ~ lognormal(log(Hares[0]), sigma_1)" 72 | actual <- construct_data_decl(meas_obj) 73 | 74 | expected <- " real y0;" 75 | 76 | expect_equal(actual, expected) 77 | }) 78 | -------------------------------------------------------------------------------- /man/sd_sensitivity_run.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulators.R 3 | \name{sd_sensitivity_run} 4 | \alias{sd_sensitivity_run} 5 | \title{Perform a sensitivity run on a System Dynamics model} 6 | \usage{ 7 | sd_sensitivity_run( 8 | ds_inputs, 9 | consts_df = NULL, 10 | stocks_df = NULL, 11 | start_time = NULL, 12 | stop_time = NULL, 13 | timestep = NULL, 14 | integ_method = "euler", 15 | multicore = FALSE, 16 | n_cores = NULL, 17 | reporting_interval = 1 18 | ) 19 | } 20 | \arguments{ 21 | \item{ds_inputs}{A list of deSolve inputs generated by read_xmile} 22 | 23 | \item{consts_df}{A data frame that contains the values of constants to 24 | simulate. Each column corresponds to a constant and each row to an 25 | iteration. If \code{stocks_df} is also supplied, both data frames must have 26 | the same number of rows.} 27 | 28 | \item{stocks_df}{A data frame that containts the initial value of stocks to 29 | be explored. Each column corresponds to a stock and each row to an 30 | iteration. If \code{consts_df} is also supplied, both data frames must have 31 | the same number of rows.} 32 | 33 | \item{start_time}{A number indicating the time at which the simulation begins.} 34 | 35 | \item{stop_time}{A number indicating the time at which the simulation ends.} 36 | 37 | \item{timestep}{A number indicating the time interval for the simulation. 38 | Also known as \code{dt}.} 39 | 40 | \item{integ_method}{A string indicating the integration method. It can be 41 | either "euler" or "rk4"} 42 | 43 | \item{multicore}{A boolean value that indicates whether the process 44 | is parallelised.} 45 | 46 | \item{n_cores}{An integer indicating the number of cores for the parallel run.} 47 | 48 | \item{reporting_interval}{A real number indicating the interval at which the 49 | simulation results are returned. The default is set to \code{1}. For 50 | instance, if the simulation runs from 0 to 10. This function returns the 51 | results at times 0, 1, 2, ..., 10.} 52 | } 53 | \value{ 54 | A data frame 55 | } 56 | \description{ 57 | \code{sd_sensitivity_run} returns a data frame with the simulation of a 58 | model for several iterations of different inputs. 59 | } 60 | \examples{ 61 | path <- system.file("models", "SIR.stmx", package = "readsdr") 62 | ds_inputs <- xmile_to_deSolve(path) 63 | consts_df <- data.frame(i = c(0.25, 0.30)) 64 | sd_sensitivity_run(ds_inputs, consts_df) 65 | } 66 | -------------------------------------------------------------------------------- /R/stat_funs.R: -------------------------------------------------------------------------------- 1 | translate_stat_funs <- function(equation, vendor) { 2 | translate_NORMAL(equation, vendor) 3 | } 4 | 5 | translate_NORMAL <- function(equation, vendor) { 6 | new_equation <- equation 7 | 8 | if(vendor == "isee") { 9 | detection_pattern <- "\\bNORMAL\\b" 10 | pattern_found <- stringr::str_detect(equation, detection_pattern) 11 | 12 | if(pattern_found) { 13 | 14 | validation_pattern <- stringr::regex("NORMAL\\((.+?)\\)", 15 | dotall = TRUE, ignore_case = TRUE) 16 | 17 | validation_match <- stringr::str_match(equation, validation_pattern) 18 | params <- stringr::str_split(validation_match[[2]], ",") 19 | n_params <- length(params[[1]]) 20 | 21 | if(n_params != 2) { 22 | stop("readsdr is restricted to translate NORMAL functions with only two parameters: mean, std_dev.", 23 | call. = FALSE) 24 | } 25 | 26 | pattern_normal <- stringr::regex("NORMAL\\((.+?),(.+?)\\)", 27 | dotall = TRUE, ignore_case = TRUE) 28 | 29 | string_match <- stringr::str_match(equation, pattern_normal) 30 | norm_mean <- string_match[[2]] 31 | norm_sd <- string_match[[3]] 32 | replacement <- stringr::str_glue("rnorm(1,{norm_mean},{norm_sd})") 33 | 34 | new_equation <- stringr::str_replace(equation, pattern_normal, 35 | replacement) 36 | } 37 | } 38 | 39 | if(vendor == "Vensim") { 40 | 41 | detection_pattern <- "\\bRANDOM_NORMAL\\b" 42 | pattern_found <- stringr::str_detect(equation, detection_pattern) 43 | 44 | if(pattern_found) { 45 | 46 | pattern_normal <- stringr::regex("RANDOM_NORMAL\\((.+?),(.+?),(.+?),(.+?),(.+?)\\)", 47 | dotall = TRUE, ignore_case = TRUE) 48 | 49 | string_match <- stringr::str_match(equation, pattern_normal) 50 | min_val <- string_match[[2]] 51 | max_val <- string_match[[3]] 52 | norm_mean <- string_match[[4]] 53 | norm_sd <- string_match[[5]] 54 | replacement <- stringr::str_glue("truncnorm::rtruncnorm(1,{min_val},{max_val},{norm_mean},{norm_sd})") 55 | 56 | new_equation <- stringr::str_replace(equation, pattern_normal, 57 | replacement) 58 | 59 | } 60 | } 61 | 62 | new_equation 63 | } 64 | 65 | -------------------------------------------------------------------------------- /tests/testthat/test-stan_utils.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("get_dist_obj() declares the vector for init values", { 3 | 4 | rhs <- "neg_binomial_2(net_flow(C), phi)" 5 | 6 | actual <- get_dist_obj(rhs) 7 | 8 | expected <- list(dist_name = "neg_binomial_2", 9 | mu = "net_flow(C)", 10 | phi = "phi") 11 | 12 | expect_equal(actual, expected) 13 | }) 14 | 15 | test_that("get_meas_params() deals with a given concentration parameter", { 16 | 17 | meas_mdl <- list("y ~ neg_binomial_2(net_flow(C), 10)") 18 | estimated_params <- list(sd_prior("par_beta", "lognormal", c(0, 1))) 19 | 20 | actual <- get_meas_params(meas_mdl, estimated_params) 21 | expected <- estimated_params 22 | 23 | expect_equal(actual, expected) 24 | }) 25 | 26 | test_that("get_meas_params() handles priors for measurement parameters", { 27 | 28 | meas_mdl <- list("y1 ~ lognormal(log(Lynx), sigma_1)") 29 | 30 | estimated_params <- list(sd_prior("par_alpha", "normal", c(1, 0.5), 31 | min = 0), 32 | sd_prior("sigma_1", "lognormal", c(-1, 1))) 33 | 34 | actual <- get_meas_params(meas_mdl, estimated_params) 35 | 36 | expected <- list(sd_prior("par_alpha", "normal", c(1, 0.5), 37 | min = 0), 38 | list(par_name = "sigma_1", 39 | dist = "lognormal", 40 | type = "meas_par", 41 | mu = -1, 42 | sigma = 1, 43 | min = 0)) 44 | 45 | expect_equal(actual, expected) 46 | }) 47 | 48 | test_that("translate_stock_text() returns the expected object", { 49 | 50 | lvl_names <- c("Hares", "Lynx") 51 | delta_counter <- 1 52 | stock_txt <- "log(Hares[0])" 53 | 54 | actual <- translate_stock_text(stock_txt, delta_counter, lvl_names) 55 | 56 | expected <- list(stock_txt = "log(x0[1])", 57 | delta_counter = 1) 58 | 59 | expect_equal(actual, expected) 60 | }) 61 | 62 | #---------tidy_meas_params()------------------------------------------------ 63 | 64 | test_that("tidy_meas_params() returns the expected list", { 65 | 66 | meas_obj <- "y ~ neg_binomial_2(net_flow(C), phi)" 67 | actual <- tidy_meas_params(meas_obj, list()) 68 | 69 | expected <- list( 70 | list(par_name = "inv_phi", 71 | dist = "exponential", 72 | beta = 5, 73 | min = 0, 74 | type = "meas_par", 75 | par_trans = "inv")) 76 | 77 | expect_equal(actual, expected) 78 | }) 79 | -------------------------------------------------------------------------------- /tests/testthat/test-posterior_fun.R: -------------------------------------------------------------------------------- 1 | test_that("sd_posterior_fun() returns the expected function", { 2 | 3 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 4 | 5 | meas_data_mdl <- list(list(formula = "y ~ neg_binomial_2(net_flow(C), phi)", 6 | measurements = 1:10)) 7 | 8 | estimated_params <- list( 9 | sd_prior("par_beta", "lognormal", c(0, 1)), 10 | sd_prior("par_rho", "beta", c(2, 2)), 11 | sd_prior("I0", "lognormal", c(0, 1), "init")) 12 | 13 | actual_obj <- sd_posterior_fun(filepath, meas_data_mdl, estimated_params) 14 | 15 | actual_fun <- actual_obj$fun 16 | 17 | actual_val <- actual_fun(c(log(1), logit(0.75), log(1), log(3))) 18 | 19 | expected_val <- -302.0369419999466345 20 | 21 | expect_equal(actual_val, expected_val) 22 | }) 23 | 24 | test_that("log_prior_fun_generator() returns the expected function", { 25 | 26 | estimated_params <- list( 27 | sd_prior("par_beta", "lognormal", c(0, 1)), 28 | sd_prior("par_rho", "beta", c(2, 2)), 29 | sd_prior("I0", "lognormal", c(0, 1), "init")) 30 | 31 | meas_data_mdl <- list(list(formula = "y ~ neg_binomial_2(net_flow(C), phi)", 32 | measurements = 1:10)) 33 | 34 | log_prior_fun <- log_prior_fun_generator(estimated_params, meas_data_mdl) 35 | 36 | actual_val <- log_prior_fun(c(log(1), logit(0.75), log(1), log(3))) 37 | 38 | expected_val <- dlnorm(1, 0, 1, log = TRUE) + dbeta(0.75, 2, 2, log = TRUE) + 39 | dlnorm(1, 0, 1, log = TRUE) + dexp(1/3, rate = 5, log = TRUE) 40 | 41 | expect_equal(actual_val, expected_val) 42 | }) 43 | 44 | test_that("build_prior_expr() returns the expected string", { 45 | 46 | par_obj <- list(par_name = "par_beta", 47 | dist = "lognormal", 48 | mu = 0, 49 | sigma = 1, 50 | par_trans = "exp", 51 | index = 1) 52 | 53 | actual <- build_prior_expr(par_obj) 54 | 55 | expected <- " dlnorm(exp(pars[[1]]), meanlog = 0, sdlog = 1, log = TRUE)" 56 | 57 | expect_equal(actual, expected) 58 | 59 | }) 60 | 61 | test_that("constrain_pars() returns the expected string", { 62 | 63 | par_obj <- list(par_trans = "exp", 64 | index = 1) 65 | 66 | actual <- constrain_pars(par_obj) 67 | 68 | expected <- "exp(pars[[1]])" 69 | 70 | expect_equal(actual, expected) 71 | 72 | 73 | par_obj <- list(par_trans = c("exp", "inv"), 74 | index = 4) 75 | 76 | actual <- constrain_pars(par_obj) 77 | 78 | expected <- "inv(exp(pars[[4]]))" 79 | 80 | expect_equal(actual, expected) 81 | }) 82 | -------------------------------------------------------------------------------- /R/create_stan_function.R: -------------------------------------------------------------------------------- 1 | #' Create a Stan's ODE function from an XMILE file 2 | #' 3 | #' \code{create_stan_function} returns a string with the code for a Stan's ODE function 4 | #' 5 | #' This function extracts the xml from the file specified via \code{filepath} to 6 | #' generate the code for an equivalent model in Stan. 7 | #' 8 | #' @param override.consts A list in which each element is a name-value pair that 9 | #' replaces values of constants. 10 | #' @param additional_funs A vector of strings. Each string corresponds to a 11 | #' user-defined function. 12 | #' @inheritParams read_xmile 13 | #' @inheritParams stan_ode_function 14 | #' 15 | #' @return A string with the code containing the model's equations in the 16 | #' format required by Stan. 17 | #' @export 18 | #' 19 | #' @examples 20 | #' path <- system.file("models", "SIR.stmx", package = "readsdr") 21 | #' create_stan_function(path, "my_model") 22 | 23 | create_stan_function <- function (filepath, func_name, pars = NULL, 24 | override.consts = NULL, 25 | additional_funs = NULL) { 26 | 27 | XMILE_structure <- extract_structure_from_XMILE(filepath) 28 | 29 | levels <- XMILE_structure$levels 30 | variables <- XMILE_structure$variables 31 | constants <- XMILE_structure$constants 32 | 33 | n_stocks <- length(levels) 34 | level_names <- get_names(levels) 35 | 36 | function_name_line <- paste0(" real[] ", func_name, "(real time,") 37 | diff_eq_declaration_line <- paste0(" real dydt[", n_stocks, "];") 38 | 39 | const_names <- get_names(constants) 40 | 41 | purrr::walk(override.consts, function(const_list) { 42 | pos <- which(const_list$name == const_names) 43 | constants[[pos]]$value <<- const_list$value 44 | }) 45 | 46 | constants <- set_unknowns(pars, constants) 47 | 48 | vars_declaration <- get_auxs_declaration(variables) 49 | 50 | vars_equations <- get_equations(variables, constants, level_names) 51 | 52 | counter <- 0 53 | diff_eq <- get_diffeq(levels) 54 | 55 | stan_function <- paste( 56 | "functions {", 57 | function_name_line , 58 | " real[] y,", 59 | " real[] params,", 60 | " real[] x_r,", 61 | " int[] x_i) {", 62 | diff_eq_declaration_line, 63 | vars_declaration, 64 | vars_equations, 65 | diff_eq, 66 | " return dydt;", 67 | " }", 68 | sep = "\n") 69 | 70 | if(!is.null(additional_funs)) { 71 | af_text <- paste(additional_funs, sep = "\n") 72 | stan_function <- paste(stan_function, af_text, sep = "\n") 73 | } 74 | 75 | stan_function <- paste(stan_function, "}", sep = "\n") 76 | } 77 | 78 | 79 | -------------------------------------------------------------------------------- /tests/testthat/test-sanitise_xml.R: -------------------------------------------------------------------------------- 1 | test_that("sanitise_xml() escapes comparison operators for a single equation", { 2 | test_text <- ' 3 | 4 | 5 | 6 | IF_THEN_ELSE(a > b :AND: a <= c , a, 0) 7 | 8 | 9 | ' 10 | 11 | actual_output <- sanitise_xml(test_text) 12 | 13 | expected_output <- ' 14 | 15 | 16 | 17 | IF_THEN_ELSE(a > b :AND: a <= c , a, 0) 18 | 19 | 20 | ' 21 | 22 | expect_equal(actual_output, expected_output) 23 | }) 24 | 25 | test_that("sanitise_xml() escapes comparison operators for multiple equation", { 26 | test_text <- ' 27 | 28 | 29 | 30 | IF_THEN_ELSE(a > b :AND: a <= c , a, 0) 31 | 32 | 33 | 34 | 35 | IF_THEN_ELSE(b > a :AND: c <= a , 0, a) 36 | 37 | 38 | 39 | 40 | IF_THEN_ELSE(b < a :AND: c >= a , b, a) 41 | 42 | 43 | ' 44 | 45 | actual_output <- sanitise_xml(test_text) 46 | 47 | expected_output <- ' 48 | 49 | 50 | 51 | IF_THEN_ELSE(a > b :AND: a <= c , a, 0) 52 | 53 | 54 | 55 | 56 | IF_THEN_ELSE(b > a :AND: c <= a , 0, a) 57 | 58 | 59 | 60 | 61 | IF_THEN_ELSE(b < a :AND: c >= a , b, a) 62 | 63 | 64 | ' 65 | 66 | expect_equal(actual_output, expected_output) 67 | }) 68 | 69 | test_that("sanitise_xml() does not alter the original xml code", { 70 | test_text <- ' 71 | 72 | 73 | 74 | a + b 75 | 76 | 77 | a + c 78 | 79 | 80 | b + c 81 | 82 | 83 | ' 84 | 85 | actual_output <- sanitise_xml(test_text) 86 | 87 | expected_output <- ' 88 | 89 | 90 | 91 | a + b 92 | 93 | 94 | a + c 95 | 96 | 97 | b + c 98 | 99 | 100 | ' 101 | 102 | expect_equal(actual_output, expected_output) 103 | }) 104 | 105 | 106 | -------------------------------------------------------------------------------- /tests/testthat/test-xmile_graph_funs.R: -------------------------------------------------------------------------------- 1 | test_that("translate_Vensim_graph_func() returns the expected object", { 2 | test_equation <- "WITHLOOKUP(Price,([(0,10)-(50,100)],(5,100),(10,73),(15,57),(20,45),(25,35),(30,28),(35,22),(40,18),(45,14),(50,10)))" 3 | 4 | actual_obj <- translate_Vensim_graph_func(test_equation) 5 | expected_obj <- list( 6 | input = "Price", 7 | graph_fun = approxfun( 8 | x = seq(5, 50, 5), 9 | y = c(100, 73, 57, 45, 35, 28, 22, 18, 14, 10), 10 | method = "linear", 11 | yleft = 100, 12 | yright = 10)) 13 | 14 | comparison_result <- all.equal(actual_obj, expected_obj, 15 | check.environment = FALSE) 16 | 17 | expect_equal(comparison_result, TRUE) 18 | }) 19 | 20 | test_that("translate_graph_func() returns the expected object", { 21 | test_gf_xml <- xml2::read_xml(' 22 | 23 | 24 | 25 | Price 26 | 27 | 28 | 29 | 100,73,57,45,35,28,22,18,14,10 30 | 31 | 32 | 33 | ') |> 34 | xml2::xml_find_first(".//d1:gf") 35 | 36 | actual_obj <- translate_graph_func(test_gf_xml) 37 | 38 | expected_obj <- approxfun( 39 | x = seq(5, 50, 5), 40 | y = c(100, 73, 57, 45, 35, 28, 22, 18, 14, 10), 41 | method = "linear", 42 | yleft = 100, 43 | yright = 10) 44 | 45 | comparison_result <- all.equal(actual_obj, expected_obj) 46 | 47 | expect_equal(comparison_result, TRUE) 48 | }) 49 | 50 | test_that("translate_graph_func() ignores yscale when ypts is defined", { 51 | 52 | test_gf_xml <- xml2::read_xml(' 53 | 54 | 55 | 56 | TIME 57 | 58 | 59 | 1,53,105,157,209,261,313,365,417,469,521 60 | 4695,4745,4755,4796,4841,4862,4932,5025,5125,5209,5303 61 | 62 | People 63 | 64 | 65 | ') |> 66 | xml2::xml_find_first(".//d1:gf") 67 | 68 | 69 | actual_obj <- translate_graph_func(test_gf_xml) 70 | 71 | expected_obj <- approxfun( 72 | x = c(1, 53, 105, 157, 209, 261, 313, 365, 417, 469, 521), 73 | y = c(4695, 4745, 4755, 4796, 4841, 4862, 4932, 5025, 5125, 5209, 5303), 74 | method = "linear", 75 | yleft = 4695, 76 | yright = 5303) 77 | 78 | comparison_result <- all.equal(actual_obj, expected_obj) 79 | 80 | expect_equal(comparison_result, TRUE) 81 | 82 | }) 83 | -------------------------------------------------------------------------------- /tests/testthat/test_stan_files/SE3I3R_pois.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[11] dydt; 6 | real S_to_E; 7 | real dly_E_to_I_1_out; 8 | real dly_E_to_I_2_out; 9 | real dly_E_to_I_3_out; 10 | real dly_S_to_E_1_out; 11 | real dly_S_to_E_2_out; 12 | real dly_S_to_E_3_out; 13 | real I_to_R; 14 | real E_to_I; 15 | real C_in; 16 | S_to_E = params[1]*y[7]*y[9]/10000; 17 | dly_E_to_I_1_out = y[1]/((2)/3.0); 18 | dly_E_to_I_2_out = y[2]/((2)/3.0); 19 | dly_E_to_I_3_out = y[3]/((2)/3.0); 20 | dly_S_to_E_1_out = y[4]/((2)/3.0); 21 | dly_S_to_E_2_out = y[5]/((2)/3.0); 22 | dly_S_to_E_3_out = y[6]/((2)/3.0); 23 | I_to_R = dly_E_to_I_3_out; 24 | E_to_I = dly_S_to_E_3_out; 25 | C_in = params[2]*E_to_I; 26 | dydt[1] = E_to_I - dly_E_to_I_1_out; 27 | dydt[2] = dly_E_to_I_1_out - dly_E_to_I_2_out; 28 | dydt[3] = dly_E_to_I_2_out - dly_E_to_I_3_out; 29 | dydt[4] = S_to_E - dly_S_to_E_1_out; 30 | dydt[5] = dly_S_to_E_1_out - dly_S_to_E_2_out; 31 | dydt[6] = dly_S_to_E_2_out - dly_S_to_E_3_out; 32 | dydt[7] = -S_to_E; 33 | dydt[8] = S_to_E-E_to_I; 34 | dydt[9] = E_to_I-I_to_R; 35 | dydt[10] = I_to_R; 36 | dydt[11] = C_in; 37 | return dydt; 38 | } 39 | } 40 | data { 41 | int n_obs; 42 | array[n_obs] int y; 43 | array[n_obs] real ts; 44 | } 45 | parameters { 46 | real par_beta; 47 | real par_rho; 48 | real I0; 49 | } 50 | transformed parameters{ 51 | array[n_obs] vector[11] x; // Output from the ODE solver 52 | array[2] real params; 53 | vector[11] x0; // init values 54 | array[n_obs] real delta_x_1; 55 | x0[1] = ((0.5)*I0 * 1/(0.5)) / (3); // dly_E_to_I_1 56 | x0[2] = ((0.5)*I0 * 1/(0.5)) / (3); // dly_E_to_I_2 57 | x0[3] = ((0.5)*I0 * 1/(0.5)) / (3); // dly_E_to_I_3 58 | x0[4] = 0; // dly_S_to_E_1 59 | x0[5] = 0; // dly_S_to_E_2 60 | x0[6] = 0; // dly_S_to_E_3 61 | x0[7] = (10000) - I0; // S 62 | x0[8] = 0; // E 63 | x0[9] = I0; // I 64 | x0[10] = 0; // R 65 | x0[11] = 0; // C 66 | params[1] = par_beta; 67 | params[2] = par_rho; 68 | x = ode_rk45(X_model, x0, 0, ts, params); 69 | delta_x_1[1] = x[1, 11] - x0[11] + 1e-5; 70 | for (i in 1:n_obs-1) { 71 | delta_x_1[i + 1] = x[i + 1, 11] - x[i, 11] + 1e-5; 72 | } 73 | } 74 | model { 75 | par_beta ~ lognormal(0, 1); 76 | par_rho ~ beta(2, 2); 77 | I0 ~ lognormal(0, 1); 78 | y ~ poisson(delta_x_1); 79 | } 80 | generated quantities { 81 | real log_lik; 82 | array[n_obs] int sim_y; 83 | log_lik = poisson_lpmf(y | delta_x_1); 84 | sim_y = poisson_rng(delta_x_1); 85 | } 86 | -------------------------------------------------------------------------------- /R/arrange_variables.R: -------------------------------------------------------------------------------- 1 | #' Arrange variables 2 | #' 3 | #' \code{arrange_variables} returns a list of auxiliary variables sorted in 4 | #' computational order 5 | #' 6 | #' This function iterates over each element until the variables are ordered in 7 | #' computational order. This is how should be used: 8 | #' 9 | #' unordered_vars <- list(list(name = "b", equation = "a + 1"), 10 | #' list(name = "a", equation = "alpha")) 11 | #' ordered_vars <- arrange_variables(unordered_vars) 12 | #' 13 | #' @param var_list A list of lists. Each second-level list corresponds to a 14 | #' variable in the model and must be a name-equation pair. Given that variables 15 | #' depend on other elements in the model, equations cannot consist of a single 16 | #' scalar. 17 | #' 18 | #' @return A list consisting of the elements in \code{var_list} but arranged in 19 | #' computational order. 20 | #' 21 | #' @noRd 22 | 23 | arrange_variables <- function(var_list) { 24 | 25 | if (length(var_list) == 0L) return (var_list) 26 | 27 | var_names <- sapply(var_list, function(varElem) varElem$name) 28 | 29 | n_equations <- length(var_names) 30 | states <- rep(0, n_equations) # Flag that indicates whether the var is defined 31 | names(states) <- var_names 32 | equations <- sapply(var_list, function(var_obj) var_obj$equation) 33 | 34 | equations_df <- data.frame(stringsAsFactors = FALSE, equation = equations) %>% 35 | dplyr::group_by(equation) %>% 36 | dplyr::mutate("ocurrence" = dplyr::row_number()) %>% 37 | dplyr::ungroup() 38 | 39 | equations_df$id <- paste(equations_df$equation, equations_df$ocurrence, 40 | sep = "_") 41 | 42 | equations_df$ocurrence <- NULL 43 | 44 | aux_ids <- equations_df$id 45 | sorted_variables <- vector(mode = "list", length = n_equations) 46 | current_pos <- 1 47 | 48 | while (length(aux_ids) > 0) { 49 | 50 | id <- aux_ids[1] 51 | pos_equation <- which(id == equations_df$id) 52 | equation <- var_list[[pos_equation]]$equation 53 | other_ids <- aux_ids[-1] 54 | lhs <- var_list[[pos_equation]]$name 55 | rh_vars <- extract_variables(lhs, equation) 56 | 57 | if(length(rh_vars) == 0L) { 58 | 59 | msg <- paste0("There are no variables in the RHS of `", lhs, "`. RHS: ", 60 | equation) 61 | 62 | stop(msg, call. = FALSE) 63 | } 64 | 65 | undefined_vars <- sapply(rh_vars, function(var){ 66 | ifelse(var %in% var_names && states[var] == 0, TRUE, FALSE) 67 | }) 68 | 69 | n_und_var <- sum(undefined_vars) 70 | 71 | if(n_und_var == 0) { 72 | sorted_variables[current_pos] <- var_list[pos_equation] 73 | states[lhs] <- 1 74 | aux_ids <- aux_ids[-1] 75 | current_pos <- current_pos + 1 76 | } 77 | 78 | if(n_und_var > 0) aux_ids <- c(other_ids, id) 79 | } 80 | 81 | sorted_variables 82 | } 83 | -------------------------------------------------------------------------------- /tests/testthat/test_stan_files/LV.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[2] dydt; 6 | real H_births; 7 | real H_deaths; 8 | real L_deaths; 9 | real L_births; 10 | H_births = params[1]*y[1]; 11 | H_deaths = params[3]*y[1]*y[2]; 12 | L_deaths = params[2]*y[2]; 13 | L_births = params[4]*y[1]*y[2]; 14 | dydt[1] = H_births-H_deaths; 15 | dydt[2] = L_births-L_deaths; 16 | return dydt; 17 | } 18 | } 19 | data { 20 | int n_obs; 21 | array[n_obs] real y; 22 | array[n_obs] real z; 23 | real y0; 24 | real z0; 25 | array[n_obs] real ts; 26 | int n_fcst; 27 | } 28 | parameters { 29 | real par_alpha; 30 | real par_gamma; 31 | real par_beta; 32 | real par_delta; 33 | real sigma_1; 34 | real sigma_2; 35 | real H0; 36 | real L0; 37 | } 38 | transformed parameters{ 39 | array[n_obs] vector[2] x; // Output from the ODE solver 40 | array[4] real params; 41 | vector[2] x0; // init values 42 | x0[1] = H0; // Hares 43 | x0[2] = L0; // Lynx 44 | params[1] = par_alpha; 45 | params[2] = par_gamma; 46 | params[3] = par_beta; 47 | params[4] = par_delta; 48 | x = ode_rk45(X_model, x0, 0, ts, params); 49 | } 50 | model { 51 | par_alpha ~ normal(1, 0.5); 52 | par_gamma ~ normal(1, 0.5); 53 | par_beta ~ normal(0.5, 0.5); 54 | par_delta ~ normal(0.5, 0.5); 55 | sigma_1 ~ lognormal(-1, 1); 56 | sigma_2 ~ lognormal(-1, 1); 57 | H0 ~ lognormal(2.30258509299405, 1); 58 | L0 ~ lognormal(2.30258509299405, 1); 59 | y ~ lognormal(log(x[:, 1]), sigma_1); 60 | z ~ lognormal(log(x[:, 2]), sigma_2); 61 | y0 ~ lognormal(log(x0[1]), sigma_1); 62 | z0 ~ lognormal(log(x0[2]), sigma_1); 63 | } 64 | generated quantities { 65 | real log_lik; 66 | array[n_obs] real sim_y; 67 | array[n_obs] real sim_z; 68 | real sim_y0; 69 | real sim_z0; 70 | array[n_fcst] real fcst_y; 71 | array[n_fcst] real fcst_z; 72 | array[n_fcst] vector[2] x_fcst; // Forecast 73 | array[n_fcst] real t_fcst; 74 | vector[2] x_fcst0; // Forecast init values 75 | log_lik = lognormal_lpdf(y | log(x[:, 1]), sigma_1) + 76 | lognormal_lpdf(z | log(x[:, 2]), sigma_2) + 77 | lognormal_lpdf(y0 | log(x0[1]), sigma_1) + 78 | lognormal_lpdf(z0 | log(x0[2]), sigma_1); 79 | // Simulate forecast 80 | x_fcst0 = x[n_obs, :]; 81 | t_fcst = linspaced_array(n_fcst, 1, n_fcst); 82 | x_fcst = ode_rk45(X_model, x_fcst0, 0, t_fcst, params); 83 | sim_y = lognormal_rng(log(x[:, 1]), sigma_1); 84 | sim_z = lognormal_rng(log(x[:, 2]), sigma_2); 85 | sim_y0 = lognormal_rng(log(x0[1]), sigma_1); 86 | sim_z0 = lognormal_rng(log(x0[2]), sigma_1); 87 | fcst_y = lognormal_rng(log(x_fcst[:, 1]), sigma_1); 88 | fcst_z = lognormal_rng(log(x_fcst[:, 2]), sigma_2); 89 | } 90 | -------------------------------------------------------------------------------- /R/what_if_from_time.R: -------------------------------------------------------------------------------- 1 | #' What if from time t we change the value of some parameters 2 | #' 3 | #' @param time Time at which the parameter values change 4 | #' @param up_to_time Time from which the original values are restored. 5 | #' @param par_list A list that indicates which parameters change from time t. 6 | #' For instance, if you wanted to change the value of parameter \code{c} to 4, 7 | #' you would provide the \code{list(c = 4)} 8 | #' 9 | #' @inheritParams sd_simulate 10 | #' 11 | #' @return A data frame 12 | #' @export 13 | #' 14 | #' @examples 15 | #' filepath <- system.file("models/", "SIR.stmx", package = "readsdr") 16 | #' mdl <- read_xmile(filepath) 17 | #' ds_components <- mdl$deSolve_components 18 | #' output <- sd_what_if_from_time(3, Inf, list(c = 4), ds_components) 19 | sd_what_if_from_time <- function(time, up_to_time = Inf, par_list, ds_inputs, 20 | start_time = NULL, stop_time = NULL, 21 | timestep = NULL, integ_method = "euler") { 22 | 23 | stopifnot("'up_to_time' must be greater than 'time'" = up_to_time > time) 24 | 25 | unchanged_consts <- ds_inputs$consts 26 | 27 | if(!is.null(start_time)) { 28 | ds_inputs$sim_params$start <- start_time 29 | } 30 | 31 | if(!is.null(stop_time)) { 32 | ds_inputs$sim_params$stop <- stop_time 33 | } else { 34 | stop_time <- ds_inputs$sim_params$stop 35 | } 36 | 37 | if(!is.null(timestep)) { 38 | ds_inputs$sim_params$dt <- timestep 39 | } 40 | 41 | mid_time <- time 42 | 43 | first_run <- sd_simulate(ds_inputs, stop_time = mid_time, 44 | integ_method = integ_method) 45 | 46 | last_row <- utils::tail(first_run, 1) 47 | stk_names <- names(ds_inputs$stocks) 48 | new_stocks <- last_row[, stk_names] %>% unlist() 49 | ds_inputs$stocks <- new_stocks 50 | 51 | par_names <- names(par_list) 52 | ds_inputs$consts[par_names] <- unlist(par_list) 53 | 54 | 55 | sr_stop_time <- min(up_to_time, stop_time) # second run stop time 56 | 57 | second_run <- sd_simulate(ds_inputs, 58 | start_time = mid_time, 59 | stop_time = sr_stop_time, 60 | integ_method = integ_method) 61 | 62 | current_output <- rbind(utils::head(first_run, -1), second_run) 63 | 64 | if(is.infinite(up_to_time)) return(current_output) 65 | 66 | last_row <- utils::tail(current_output, 1) 67 | stk_names <- names(ds_inputs$stocks) 68 | new_stocks <- last_row[, stk_names] %>% unlist() 69 | ds_inputs$stocks <- new_stocks 70 | ds_inputs$consts <- unchanged_consts 71 | 72 | third_run <- sd_simulate(ds_inputs, 73 | start_time = sr_stop_time, 74 | stop_time = stop_time, 75 | integ_method = integ_method) 76 | 77 | rbind(utils::head(current_output, -1), third_run) 78 | } 79 | -------------------------------------------------------------------------------- /R/prior_checks.R: -------------------------------------------------------------------------------- 1 | #' Prior predictive checks 2 | #' 3 | #' @param n_draws An integer that indicates how many time-series will be 4 | #' returned. 5 | #' @inheritParams read_xmile 6 | #' @inheritParams sd_Bayes 7 | #' @inheritParams sd_simulate 8 | #' 9 | #' @return A list of two data frames. 10 | #' @export 11 | #' 12 | #' @examples 13 | #' filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 14 | #' meas_mdl <- list("y ~ neg_binomial_2(net_flow(C), phi)") 15 | #' estimated_params <- list( 16 | #' sd_prior("par_beta", "lognormal", c(0, 1)), 17 | #' sd_prior("par_rho", "beta", c(2, 2)), 18 | #' sd_prior("I0", "lognormal", c(0, 1), "init")) 19 | #' sd_prior_checks(filepath, meas_mdl, estimated_params, n_draws = 2, 20 | #' start_time = 0, stop_time = 5, 21 | #' integ_method = "rk4", timestep = 1/32) 22 | sd_prior_checks <- function(filepath, meas_mdl, estimated_params, n_draws, 23 | start_time = NULL, 24 | stop_time = NULL, 25 | timestep = NULL, 26 | integ_method = "euler") { 27 | 28 | pars_names <- get_names(estimated_params, "par_name") 29 | 30 | estimated_params <- get_meas_params(meas_mdl, estimated_params) 31 | unk_types <- sapply(estimated_params, 32 | function(prior_obj) prior_obj$type) 33 | 34 | idx_meas <- which(unk_types == "meas_par") 35 | n_meas_par <- length(idx_meas) 36 | 37 | prior_fun_list <- prior_fun_factory(estimated_params, n_draws) 38 | prior_vals <- lapply(prior_fun_list, 39 | function(prior_fun) prior_fun()) 40 | 41 | df1 <- cbind(data.frame(iter = 1:n_draws), as.data.frame(prior_vals)) 42 | 43 | 44 | mdl_structure <- extract_structure_from_XMILE(filepath, pars_names) 45 | ds_inputs <- get_deSolve_elems(mdl_structure) 46 | 47 | if(!(integ_method %in% c("euler", "rk4"))) stop("Invalid integration method") 48 | 49 | ds_inputs <- update_sim_params(ds_inputs, start_time, stop_time, timestep) 50 | 51 | if(n_meas_par > 0) { 52 | 53 | meas_params <- estimated_params[idx_meas] 54 | 55 | # List of configured measurement models. 56 | meas_mdl_conf <- configure_meas_models(meas_mdl, meas_params, prior_vals) 57 | } 58 | 59 | df2 <- purrr::map_dfr(1:n_draws, function(i) { 60 | 61 | for(param in pars_names) ds_inputs$consts[[param]] <- prior_vals[[param]][[i]] 62 | 63 | par_list <- unlist(purrr::transpose(prior_vals)[i], recursive = FALSE) 64 | readsdr_env <- list2env(par_list) 65 | 66 | ds_inputs$stocks <- purrr::map_dbl(ds_inputs$stocks, function(x) { 67 | 68 | eval(parse(text = x), envir = readsdr_env) 69 | }) 70 | 71 | measurement_df <- sd_measurements(1, meas_mdl_conf[[i]], 72 | ds_inputs, 73 | integ_method = integ_method) 74 | measurement_df$iter <- i 75 | measurement_df 76 | }) 77 | 78 | 79 | list(parameters = df1, 80 | measurements = df2) 81 | } 82 | 83 | 84 | -------------------------------------------------------------------------------- /tests/testthat/test-extract_variables.R: -------------------------------------------------------------------------------- 1 | test_that("extract_variables() returns variables in equations that have numbers & exponents", { 2 | test_lhs <- "test_var" 3 | equation <- "gamma * (1 + beta) ^ alpha" 4 | actual_vars <- extract_variables(test_lhs, equation) 5 | actual_vars <- sort(actual_vars) 6 | expected_vars <- c("alpha", "beta", "gamma") 7 | expect_equal(actual_vars, expected_vars) 8 | }) 9 | 10 | test_that("extract_variables() ignores min function", { 11 | test_lhs <- "test_var" 12 | equation <- "min(minimiser, maximiser)" 13 | actual_vars <- extract_variables(test_lhs, equation) 14 | actual_vars <- sort(actual_vars) 15 | expected_vars <- c("maximiser", "minimiser") 16 | expect_equal(actual_vars, expected_vars) 17 | }) 18 | 19 | test_that("extract_variables() ignores max function", { 20 | test_lhs <- "test_var" 21 | equation <- "max(minimiser, maximiser)" 22 | actual_vars <- extract_variables(test_lhs, equation) 23 | actual_vars <- sort(actual_vars) 24 | expected_vars <- c("maximiser", "minimiser") 25 | expect_equal(actual_vars, expected_vars) 26 | }) 27 | 28 | test_that("extract_variables() ignores graph functions", { 29 | test_lhs <- "test_var" 30 | equation <- "f_test_var(a + b)" 31 | actual_vars <- extract_variables(test_lhs, equation) 32 | actual_vars <- sort(actual_vars) 33 | expected_vars <- c("a", "b") 34 | expect_equal(actual_vars, expected_vars) 35 | }) 36 | 37 | test_that("extract_variables() returns unique elements", { 38 | test_lhs <- "test_var" 39 | equation <- "a^2 + 2*a*b + b^2" 40 | actual_vars <- extract_variables(test_lhs, equation) 41 | actual_vars <- sort(actual_vars) 42 | expected_vars <- c("a", "b") 43 | expect_equal(actual_vars, expected_vars) 44 | }) 45 | 46 | test_that("extract_variables() ignores ifelse functions", { 47 | test_lhs <- "test_var" 48 | equation <- "ifelse(a + b, a, b)" 49 | actual_vars <- extract_variables(test_lhs, equation) 50 | actual_vars <- sort(actual_vars) 51 | expected_vars <- c("a", "b") 52 | expect_equal(actual_vars, expected_vars) 53 | }) 54 | 55 | test_that("extract_variables() ignores logical operators", { 56 | test_lhs <- "test_var" 57 | equation <- "ifelse(!(a>b)&a>c|cb:AND:a>c" 5 | actual_val <- translate_AND(test_equation, "Vensim") 6 | expected_val <- 'a>b&a>c' 7 | expect_equal(actual_val, expected_val) 8 | }) 9 | 10 | test_that("translate_AND() returns for the correct translation for expressions from Stella", { 11 | test_equation <- "ifelse(a>5AND(a<10),1,0)" 12 | actual_val <- translate_AND(test_equation, "isee") 13 | expected_val <- 'ifelse(a>5&(a<10),1,0)' 14 | expect_equal(actual_val, expected_val) 15 | }) 16 | 17 | test_that("translate_AND() returns for the correct translation for compounded expressions from Stella", { 18 | test_equation <- "ifelse(a>5AND(a<10)AND(a<15),0.1,0)" 19 | actual_val <- translate_AND(test_equation, "isee") 20 | expected_val <- "ifelse(a>5&(a<10)&(a<15),0.1,0)" 21 | expect_equal(actual_val, expected_val) 22 | }) 23 | 24 | context("Translate OR") 25 | 26 | test_that("translate_OR() returns for the correct translation for expressions from VENSIM", { 27 | test_equation <- "a>b:OR:a>c" 28 | actual_val <- translate_OR(test_equation, "Vensim") 29 | expected_val <- 'a>b|a>c' 30 | expect_equal(actual_val, expected_val) 31 | }) 32 | 33 | test_that("translate_OR() returns for the correct translation for expressions from Stella", { 34 | test_equation <- "ifelse(a>5OR(a<10),1,0)" 35 | actual_val <- translate_OR(test_equation, "isee") 36 | expected_val <- 'ifelse(a>5|(a<10),1,0)' 37 | expect_equal(actual_val, expected_val) 38 | }) 39 | 40 | test_that("translate_OR() dealw with cases for expressions from Stella", { 41 | test_equation <- "ifelse(a>5or(a<10),1,0)" 42 | actual_val <- translate_OR(test_equation, "isee") 43 | expected_val <- 'ifelse(a>5|(a<10),1,0)' 44 | expect_equal(actual_val, expected_val) 45 | }) 46 | 47 | test_that("translate_OR() returns for the correct translation for compounded expressions from Stella", { 48 | test_equation <- "ifelse(a>5OR(a<10)OR(a<15),0.1,0)" 49 | actual_val <- translate_OR(test_equation, "isee") 50 | expected_val <- "ifelse(a>5|(a<10)|(a<15),0.1,0)" 51 | expect_equal(actual_val, expected_val) 52 | }) 53 | 54 | context("Translate NOT") 55 | 56 | test_that("translate_NOT() returns for the correct translation for expressions from Stella", { 57 | test_equation <- "NOT(time=3)" 58 | actual_val <- translate_NOT(test_equation, "isee") 59 | expected_val <- '!(time=3)' 60 | expect_equal(actual_val, expected_val) 61 | }) 62 | 63 | test_that("translate_NOT() returns for the correct translation for compounded expressions from Stella", { 64 | test_equation <- "ifelse(NOT(time=3),0,1)" 65 | actual_val <- translate_NOT(test_equation, "isee") 66 | expected_val <- 'ifelse(!(time=3),0,1)' 67 | expect_equal(actual_val, expected_val) 68 | }) 69 | 70 | test_that("translate_NOT() returns for the correct translation for expressions from Vensim", { 71 | test_equation <- "ifelse(:NOT:Time=3,0,1)" 72 | actual_val <- translate_NOT(test_equation, "Vensim") 73 | expected_val <- 'ifelse(!Time=3,0,1)' 74 | expect_equal(actual_val, expected_val) 75 | }) 76 | 77 | -------------------------------------------------------------------------------- /R/priors.R: -------------------------------------------------------------------------------- 1 | #' Specify priors for the estimated parameters. 2 | #' 3 | #'\code{sd_prior} returns a list characterising the features of the prior. 4 | #' 5 | #' @param par_name A string indicating the name of the estimated parameter. 6 | #' @param dist A string indicating the name of the prior distribution. This name 7 | #' should be consistent with Stan language. For instance, "normal" indicates 8 | #' the normal distribution in Stan language. 9 | #' @param dist_pars A numeric vector. For instance, if \code{dist} = "normal", 10 | #' then \code{dist_pars} will be a vector of size 2 corresponding to 11 | #' the \emph{location} (mean) and \emph{scale} (standard deviation). 12 | #' @param type A string. It can be either 'constant' or 'init'. It is 'constant' 13 | #' by default. 'init' refers to parameters that have only affect the model at 14 | #' time 0. 15 | #' @param min An optional numeric or a string value indicating the estimated 16 | #' parameter's lower bound. This value overrides the inferred bound from the 17 | #' prior distribution. For instance, specifying a beta distribution for the 18 | #' estimated parameter inherently sets the lower bound to 0. Providing a 19 | #' value to \code{min} will override this default with the supplied value. If 20 | #' the supplied value is a string, it should be the name of another estimated 21 | #' parameter. 22 | #' @param max An optional numeric value or a string indicating the estimated 23 | #' parameter's upper bound. This value overrides the inferred bound from the 24 | #' prior distribution. For instance, specifying a beta distribution for the 25 | #' estimated parameter inherently sets the upper bound to \code{1}. Providing 26 | #' a value to \code{max} will override this default with the supplied value. 27 | #' If the supplied value is a string, it should be the name of another 28 | #' estimated parameter. 29 | #' @return A list 30 | #' @export 31 | #' 32 | #' @examples 33 | #' sd_prior("par_beta", "lognormal", c(0, 1)) 34 | #' sd_prior("par_rho", "normal", c(0, 1), min = 0) 35 | sd_prior <- function(par_name, dist, dist_pars, type = "constant", min = NULL, 36 | max = NULL) { 37 | 38 | supported_dists <- c("beta", "exponential", "lognormal", "normal") 39 | 40 | if(!dist %in% supported_dists) { 41 | 42 | msg <- paste0("sd_prior() does not support the '", dist, "' distribution.") 43 | stop(msg, call. = FALSE) 44 | } 45 | 46 | dist_obj <- list(par_name = par_name, 47 | dist = dist, 48 | type = type) 49 | 50 | if(dist == "beta") { 51 | 52 | dist_obj$alpha <- dist_pars[[1]] 53 | dist_obj$beta <- dist_pars[[2]] 54 | dist_obj$min <- 0 55 | dist_obj$max <- 1 56 | } 57 | 58 | if(dist == "exponential") { 59 | 60 | dist_obj$beta <- dist_pars[[1]] 61 | dist_obj$min <- 0 62 | } 63 | 64 | if(dist == "lognormal") { 65 | 66 | dist_obj$mu <- dist_pars[[1]] 67 | dist_obj$sigma <- dist_pars[[2]] 68 | dist_obj$min <- 0 69 | } 70 | 71 | if(dist == "normal") { 72 | 73 | dist_obj$mu <- dist_pars[[1]] 74 | dist_obj$sigma <- dist_pars[[2]] 75 | } 76 | 77 | if(!is.null(min)) dist_obj$min <- min 78 | if(!is.null(max)) dist_obj$max <- max 79 | 80 | dist_obj 81 | } 82 | -------------------------------------------------------------------------------- /man/sd_Bayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sd_bayes.R 3 | \name{sd_Bayes} 4 | \alias{sd_Bayes} 5 | \title{Create Stan file for Bayesian inference} 6 | \usage{ 7 | sd_Bayes( 8 | filepath, 9 | meas_mdl, 10 | estimated_params, 11 | data_params = NULL, 12 | data_inits = NULL, 13 | const_list = NULL, 14 | forecast = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{filepath}{A string that indicates a path to a file with extension .stmx 19 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 20 | from Vensim with extension .xmile} 21 | 22 | \item{meas_mdl}{A list of strings. Each string corresponds to a sampling 23 | statement written in Stan language.} 24 | 25 | \item{estimated_params}{A list of lists. Each sublist describes each 26 | parameter that will be estimated in the inference stage. To construct this 27 | description, the user can avail of the function `sd_prior`.} 28 | 29 | \item{data_params}{An optional string vector defining which model 30 | parameters will be configured through the Stan data block. That is, the 31 | user will provide fixed values for such parameters at every Stan run.} 32 | 33 | \item{data_inits}{An optional string vector defining which model 34 | parameters that \strong{only affect initial values} (of stocks) will be 35 | configured through the Stan data block. That is, the user will provide fixed 36 | values for such parameters at every Stan run.} 37 | 38 | \item{const_list}{A list in which each element's name is the name of the 39 | constant to override and the element's value correspond to the new value.} 40 | 41 | \item{forecast}{An optional boolean that indicates whether the Stan file 42 | supports a forecast. If \code{TRUE}, the \strong{data} block requires the 43 | user to supply an integer value for \code{n_fcst}. This variable corresponds 44 | to the number of periods that will be predicted.} 45 | } 46 | \value{ 47 | A string 48 | } 49 | \description{ 50 | Create Stan file for Bayesian inference 51 | } 52 | \section{Negative binomial measurement component}{ 53 | 54 | 55 | While this package aims to avoid making decisions for users whenever 56 | possible, I have taken the liberty to automate the transformation of phi 57 | (the concentration parameter) when using the Negative Binomial distribution 58 | (\href{https://mc-stan.org/docs/functions-reference/nbalt.html}{alternative parameterisation}) 59 | as a measurement component. \code{sd_Bayes()} automatically creates an 60 | inverse phi parameter for computational efficiency, which will be subject to 61 | inference (instead of phi). Additionally, I have provided a default prior for 62 | this inv_phi but users can override it as needed. 63 | } 64 | 65 | \section{Time}{ 66 | 67 | 68 | Simulation of the ordinary differential equation (ODE) model starts at time 0. 69 | } 70 | 71 | \examples{ 72 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 73 | mm1 <- "y ~ neg_binomial_2(net_flow(C), phi)" 74 | meas_mdl <- list(mm1) 75 | estimated_params <- list( 76 | sd_prior("par_beta", "lognormal", c(0, 1)), 77 | sd_prior("par_rho", "beta", c(2, 2)), 78 | sd_prior("I0", "lognormal", c(0, 1), "init")) 79 | sd_Bayes(filepath, meas_mdl, estimated_params) 80 | } 81 | -------------------------------------------------------------------------------- /R/stan_postprocessing.R: -------------------------------------------------------------------------------- 1 | 2 | #' Extract the values over time of a variable from a Stan fit 3 | #' 4 | #' @param var_name A string that indicates the variable's name for which the 5 | #' function will construct the timeseries. 6 | #' @param posterior_df A Stan fit object converted into a data frame 7 | #' 8 | #' @return A data frame 9 | #' @export 10 | #' 11 | #' @examples 12 | #' posterior_df <- data.frame(`var[1]` = rep(0, 2), `var[2]` = rep(1, 2), 13 | #' check.names = FALSE) 14 | #' extract_timeseries_var("var", posterior_df) 15 | extract_timeseries_var <- function(var_name, posterior_df) { 16 | posterior_cols <- colnames(posterior_df) 17 | pattern <- stringr::str_glue("{var_name}\\[.+\\]") 18 | pos_search <- grep(pattern, posterior_cols) 19 | search_cols <- posterior_cols[pos_search] 20 | search_df <- posterior_df[, search_cols] 21 | 22 | var_ts <- purrr::imap_dfr(search_df, function(col, label) { 23 | pattern <- "\\[(\\d+)\\]" 24 | match_output <- stringr::str_match(label, pattern) 25 | time_var <- as.numeric(match_output[[2]]) 26 | 27 | data.frame(stringsAsFactors = FALSE, 28 | iter = seq_along(col), 29 | time = time_var, 30 | value = col) 31 | }) 32 | 33 | var_ts$variable <- var_name 34 | var_ts <- var_ts[ , c(1:2,4, 3)] 35 | 36 | var_ts 37 | } 38 | 39 | 40 | #' Extract the values over time of a stock from a Stan fit 41 | #' 42 | #' @param stock_name A string that indicates the stock's name for which the 43 | #' function will construct the timeseries. 44 | #' @param all_stocks A vector of strings that contains the names of all the 45 | #' stocks in the model. This vector must have the same order as the differential 46 | #' equations in the Stan code. 47 | #' @param ODE_output A string that indicates the name of the variable where 48 | #' model's output in stored in Stan. 49 | #' 50 | #' @inheritParams extract_timeseries_var 51 | #' 52 | #' @return A data frame 53 | #' @export 54 | #' 55 | #' @examples 56 | #' posterior_df <- data.frame(`yhat[1,2]` = rep(0, 2), `yhat[2,2]` = rep(1, 2), 57 | #' check.names = FALSE) 58 | #' stocks <- c("S1", "S2") 59 | #' extract_timeseries_stock("S2", posterior_df, stocks, "yhat") 60 | extract_timeseries_stock <- function(stock_name, posterior_df, all_stocks, 61 | ODE_output) { 62 | 63 | posterior_cols <- colnames(posterior_df) 64 | pos_stock <- which(stock_name == all_stocks) 65 | pattern <- stringr::str_glue("{ODE_output}\\[\\d+,{pos_stock}\\]") 66 | pos_search <- grep(pattern, posterior_cols) 67 | search_cols <- posterior_cols[pos_search] 68 | search_df <- posterior_df[, search_cols] 69 | 70 | stock_ts <- purrr::imap_dfr(search_df, function(col, label) { 71 | 72 | pattern <- stringr::str_glue("{ODE_output}\\[(\\d+),\\d+\\]") 73 | match_output <- stringr::str_match(label, pattern) 74 | time_var <- as.numeric(match_output[[2]]) 75 | 76 | data.frame(stringsAsFactors = FALSE, 77 | iter = seq_along(col), 78 | time = time_var, 79 | value = col) 80 | }) 81 | 82 | stock_ts$stock <- stock_name 83 | stock_ts <- stock_ts[, c(1:2, 4, 3)] 84 | stock_ts 85 | } 86 | -------------------------------------------------------------------------------- /tests/testthat/SEjIkR.xmile: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | Vensim 5 | Ventana Systems, Inc. 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 |
15 | 16 | 1 17 | 100 18 |
0.0078125
19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 0 27 | 28 | 29 | C in 30 | 31 | 32 | 33 | 34 | 35 | 36 | 0 37 | 38 | 39 | S to E 40 | 41 | 42 | E to I 43 | 44 | 45 | 46 | 47 | 48 | 49 | E_to_I= 50 | DELAY_N(S_to_E, 1/par_sigma, 0, j) 51 | 52 | 53 | 54 | 55 | 56 | 57 | I0 58 | 59 | 60 | E to I 61 | 62 | 63 | I to R 64 | 65 | 66 | 67 | 68 | 69 | 70 | I_to_R= 71 | DELAY_N(E_to_I, 1/par_gamma, par_gamma * I0, k) 72 | 73 | 74 | 75 | 76 | 77 | 78 | 0 79 | 80 | 81 | I to R 82 | 83 | 84 | 85 | 86 | 87 | 88 | N - I0 89 | 90 | 91 | S to E 92 | 93 | 94 | 95 | 96 | 97 | par_rho * E_to_I 98 | 99 | 100 | 101 | 102 | par_beta * S * I / N 103 | 104 | 105 | 106 | 107 | 1 108 | 109 | 110 | 111 | 112 | 2 113 | 114 | 115 | 116 | 117 | 2 118 | 119 | 120 | 121 | 122 | 10000 123 | 124 | 125 | 126 | 127 | 1 128 | 129 | 130 | 131 | 132 | 0.5 133 | 134 | 135 | 136 | 137 | 0.75 138 | 139 | 140 | 141 | 142 | 0.5 143 | 144 | 145 | 146 | 147 | -------------------------------------------------------------------------------- /man/sd_loglik_fun.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/loglik_fun.R 3 | \name{sd_loglik_fun} 4 | \alias{sd_loglik_fun} 5 | \title{Generate a log-likelihood function for an SD model} 6 | \usage{ 7 | sd_loglik_fun( 8 | filepath, 9 | unknown_pars, 10 | meas_data_mdl, 11 | neg_log = FALSE, 12 | supplied_pars = NULL, 13 | start_time = NULL, 14 | stop_time = NULL, 15 | timestep = NULL, 16 | integ_method = "euler", 17 | const_list = NULL 18 | ) 19 | } 20 | \arguments{ 21 | \item{filepath}{A string that indicates a path to a file with extension .stmx 22 | or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 23 | from Vensim with extension .xmile} 24 | 25 | \item{unknown_pars}{A list of lists. Each second-level list contains at least 26 | the element name \code{name}, which corresponds to the parameter's name 27 | subject to estimation. In addition to the element \code{name}, users can 28 | incorporate in the sub-list the elements \code{min} and \code{max}. The 29 | value of \code{min} can only be \code{0}, whereas the value of \code{max} 30 | can only be \code{1}.} 31 | 32 | \item{meas_data_mdl}{A list of lists. Each second-level list corresponds to 33 | a sampling statement along with its measurements. Here is an example: \cr 34 | \code{list(formula = "y ~ neg_binomial_2(net_flow(C), phi)", 35 | measurements = 1:10))}} 36 | 37 | \item{neg_log}{A boolean that indicates whether the log-likelihood function 38 | returns a positive or negative value. If \code{TRUE}, the function 39 | returns a positive value (for minimisation optimisers). If 40 | \code{FALSE}, the function returns the original log-likelihood.} 41 | 42 | \item{supplied_pars}{A string vector indicating the name of parameters whose 43 | values will be supplied to the function. These values will not be subject to 44 | optimisation.} 45 | 46 | \item{start_time}{A number indicating the time at which the simulation begins.} 47 | 48 | \item{stop_time}{A number indicating the time at which the simulation ends.} 49 | 50 | \item{timestep}{A number indicating the time interval for the simulation. 51 | Also known as \code{dt}.} 52 | 53 | \item{integ_method}{A string indicating the integration method. It can be 54 | either "euler" or "rk4"} 55 | 56 | \item{const_list}{A list in which each element's name is the name of the 57 | constant to override and the element's value correspond to the new value.} 58 | } 59 | \value{ 60 | A list of three elements. The first element, \code{fun}, corresponds 61 | to the log likelihood function. The second element, \code{par_names}, 62 | indicates the order in which the unknowns are returned. The third element, 63 | \code{sim_params}, corresponds to the simulation parameters (start time, 64 | stop time, and the integration step or dt) employed by the solver function. 65 | } 66 | \description{ 67 | Generate a log-likelihood function for an SD model 68 | } 69 | \examples{ 70 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 71 | unknown_pars <- list(list(par_name = "par_beta", min = 0)) 72 | meas_data_mdl <- list(list(formula = "y ~ neg_binomial_2(net_flow(C), phi)", 73 | measurements = 1:10)) 74 | fun_obj <- sd_loglik_fun(filepath, unknown_pars, meas_data_mdl, neg_log = FALSE, 75 | start_time = 0, stop_time = 10, timestep = 1/32) 76 | } 77 | -------------------------------------------------------------------------------- /R/generate_igraph_inputs.R: -------------------------------------------------------------------------------- 1 | get_igraph_inputs <- function(model_structure) { 2 | 3 | levels <- model_structure$levels 4 | variables <- model_structure$variables 5 | constants <- model_structure$constants 6 | 7 | nodes_df <- generate_nodes_df(levels, variables, constants) 8 | edges_df <- generate_edges_df(levels, variables, constants) 9 | 10 | list( 11 | nodes = nodes_df, 12 | edges = edges_df 13 | ) 14 | } 15 | 16 | generate_nodes_df <- function(stocks, variables, constants) { 17 | const_names <- sapply(constants, function(const) const$name) 18 | 19 | stocks_df <- purrr::map_df(stocks, function(stock) { 20 | 21 | data.frame(name = stock$name, 22 | type = "stock", 23 | equation = stock$equation, 24 | stringsAsFactors = F) 25 | }) 26 | 27 | variables_df <- purrr::map_df(variables, function(variable) { 28 | equation <- variable$equation 29 | extracted_vars <- extract_variables(variable$name, equation) 30 | 31 | if("time" %in% extracted_vars) stop("A variable depends on time", 32 | call. = FALSE) 33 | 34 | if("rnorm" %in% extracted_vars) stop("Translation of rnorm is not supported for graphs", 35 | call. = FALSE) 36 | 37 | detected_consts <- extracted_vars[extracted_vars %in% const_names] 38 | n_det_consts <- length(detected_consts) 39 | 40 | if(n_det_consts > 0) { 41 | 42 | for(det_const in detected_consts){ 43 | 44 | regex_pattern <- stringr::regex(paste0("\\b", det_const,"\\b")) 45 | pos_const <- which(det_const == const_names) 46 | const_value <- constants[[pos_const]]$value 47 | 48 | const_value <- ifelse(is.numeric(const_value), 49 | as.character(round(const_value, 10)), 50 | const_value) 51 | 52 | equation <- stringr::str_replace_all( 53 | equation, regex_pattern, const_value) 54 | } 55 | } 56 | 57 | data.frame(name = variable$name, 58 | type = "variable", 59 | equation = equation, 60 | stringsAsFactors = F) 61 | }) 62 | 63 | dplyr::bind_rows(stocks_df, variables_df) 64 | } 65 | 66 | generate_edges_df <- function(stocks, variables, constants) { 67 | 68 | stocks_edges <- purrr::map_df(stocks, construct_stock_edge) 69 | 70 | const_names <- sapply(constants, function(constant) constant$name) 71 | 72 | variables_edges <- purrr::map_df(variables, const_names = const_names, 73 | construct_var_edge) 74 | 75 | dplyr::bind_rows(stocks_edges, variables_edges) 76 | } 77 | 78 | construct_var_edge <- function(variable, const_names) { 79 | rhs <- extract_variables(variable$name, variable$equation) 80 | rhs <- rhs[!rhs %in% const_names ] %>% unique() 81 | 82 | if(length(rhs) == 0L) return(NULL) 83 | 84 | data.frame(from = rhs, to = rep(variable$name, length(rhs)), 85 | type = "info_link", stringsAsFactors = F) 86 | } 87 | 88 | construct_stock_edge <- function(stock_obj) { 89 | rhs <- extract_variables(stock_obj$name, stock_obj$equation) 90 | 91 | if(length(rhs) == 0L) return(NULL) 92 | 93 | data.frame(from = rhs, 94 | to = rep(stock_obj$name, length(rhs)), 95 | type = "flow", 96 | stringsAsFactors = F) 97 | } 98 | -------------------------------------------------------------------------------- /R/stan_model.R: -------------------------------------------------------------------------------- 1 | stan_model <- function(estimated_params, meas_mdl, lvl_names) { 2 | 3 | prior_lines <- sapply(estimated_params, construct_prior_line) |> 4 | paste(collapse = "\n") 5 | 6 | likelihood_lines <- get_likelihood_lines(meas_mdl, lvl_names) 7 | 8 | block_body <- paste(prior_lines, likelihood_lines, sep = "\n") 9 | 10 | paste("model {", 11 | block_body, 12 | "}", sep = "\n") 13 | } 14 | 15 | construct_prior_line <- function(prior_obj) { 16 | 17 | dist_args <- get_dist_args(prior_obj$dist) 18 | 19 | dist_pars <- prior_obj[dist_args] |> 20 | as.numeric() |> 21 | paste(collapse = ", ") 22 | 23 | stringr::str_glue(" {prior_obj$par_name} ~ {prior_obj$dist}({dist_pars});") 24 | 25 | } 26 | 27 | get_likelihood_lines <- function(meas_mdl, lvl_names) { 28 | 29 | delta_counter <- 1 30 | n_meas <- length(meas_mdl) 31 | 32 | meas_lines <- vector(mode = "character", length = n_meas) 33 | 34 | for(i in seq_len(n_meas)) { 35 | 36 | meas_obj <- meas_mdl[[i]] 37 | ll_obj <- construct_likelihood_line(meas_obj, delta_counter, lvl_names) 38 | 39 | if(length(ll_obj$line) == 0) { 40 | 41 | msg <- stringr::str_glue("Failed to translate '{meas_obj}' in the model block") 42 | stop(msg, call. = FALSE) 43 | } 44 | 45 | meas_lines[[i]] <- ll_obj$line 46 | delta_counter <- ll_obj$delta_counter 47 | } 48 | 49 | paste(meas_lines, collapse = "\n") 50 | 51 | } 52 | 53 | construct_likelihood_line <- function(meas_obj, delta_counter, lvl_names) { 54 | 55 | decomposed_meas <- decompose_meas(meas_obj) 56 | lhs <- decomposed_meas$lhs 57 | dist_obj <- get_dist_obj(decomposed_meas$rhs) 58 | translation_obj <- translate_lik_rhs(dist_obj, delta_counter, lvl_names) 59 | new_rhs <- translation_obj$rhs 60 | 61 | list(line = as.character(stringr::str_glue(" {lhs} ~ {new_rhs};")), 62 | delta_counter = translation_obj$delta_counter) 63 | } 64 | 65 | translate_lik_rhs <- function(dist_obj, delta_counter, lvl_names) { 66 | 67 | return_obj <- list(rhs = NULL, 68 | delta_counter = NULL) 69 | 70 | stock_txt <- dist_obj[[2]] 71 | 72 | translation_obj <- translate_stock_text(stock_txt, delta_counter, lvl_names) 73 | 74 | return_obj$delta_counter <- translation_obj$delta_counter 75 | stock_txt <- translation_obj$stock_txt 76 | 77 | if(dist_obj$dist_name == "normal") { 78 | 79 | new_mu <- stock_txt 80 | return_obj$rhs <- stringr::str_glue("normal({new_mu}, {dist_obj$sigma})") 81 | return(return_obj) 82 | } 83 | 84 | if(dist_obj$dist_name == "neg_binomial_2") { 85 | 86 | new_mu <- stock_txt 87 | return_obj$rhs <- stringr::str_glue("neg_binomial_2({new_mu}, {dist_obj$phi})") 88 | return(return_obj) 89 | } 90 | 91 | if(dist_obj$dist_name == "poisson") { 92 | 93 | new_lambda <- stock_txt 94 | return_obj$rhs <- stringr::str_glue("poisson({new_lambda})") 95 | return(return_obj) 96 | } 97 | 98 | if(dist_obj$dist_name == "lognormal") { 99 | 100 | new_mu <- stock_txt 101 | return_obj$rhs <- stringr::str_glue("lognormal({new_mu}, {dist_obj$sigma})") 102 | return(return_obj) 103 | } 104 | 105 | msg <- paste0("translate_lik_rhs() does not support the ", 106 | dist_obj$dist_name, " distribution.") 107 | 108 | stop(msg, call. = FALSE) 109 | } 110 | -------------------------------------------------------------------------------- /R/posterior_fun.R: -------------------------------------------------------------------------------- 1 | #' Posterior function 2 | #' 3 | #' @inheritParams read_xmile 4 | #' @inheritParams sd_Bayes 5 | #' @inheritParams sd_loglik_fun 6 | #' 7 | #' @return A function 8 | #' @export 9 | #' 10 | #' @examples 11 | #' filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 12 | #' meas_data_mdl <- list(list(formula = "y ~ neg_binomial_2(net_flow(C), phi)", 13 | #' measurements = 1:10)) 14 | #' estimated_params <- list( 15 | #' sd_prior("par_beta", "lognormal", c(0, 1)), 16 | #' sd_prior("par_rho", "beta", c(2, 2)), 17 | #' sd_prior("I0", "lognormal", c(0, 1), "init")) 18 | #' fun <- sd_posterior_fun(filepath, meas_data_mdl, estimated_params) 19 | sd_posterior_fun <- function(filepath, meas_data_mdl, estimated_params, 20 | start_time = NULL, stop_time = NULL, 21 | timestep = NULL, integ_method = "euler", 22 | const_list = NULL) { 23 | 24 | 25 | ll_fun_obj <- sd_loglik_fun(filepath = filepath, 26 | unknown_pars = estimated_params, 27 | meas_data_mdl = meas_data_mdl, 28 | start_time = start_time, 29 | stop_time = stop_time, 30 | timestep = timestep, 31 | integ_method = integ_method, 32 | const_list = const_list) 33 | 34 | log_lik_fun <- ll_fun_obj$fun 35 | 36 | log_prior_fun <- log_prior_fun_generator(estimated_params, meas_data_mdl) 37 | 38 | fun <- function(pars) log_lik_fun(pars) + log_prior_fun(pars) 39 | 40 | list(fun = fun, par_list = ll_fun_obj$par_list) 41 | } 42 | 43 | log_prior_fun_generator <- function(estimated_params, meas_data_mdl) { 44 | 45 | meas_pars <- extract_meas_pars(meas_data_mdl) 46 | 47 | if(length(meas_pars) > 0) estimated_params <- c(estimated_params, meas_pars) 48 | 49 | par_list <- get_par_list(estimated_params) 50 | 51 | idx <- lapply(seq_len(length(estimated_params)), function(i) list(index = i)) 52 | 53 | par_specs <- Map(function(x, y, z) { 54 | x[['par_trans']] <- NULL 55 | c(x, y[2], z) 56 | }, estimated_params, par_list, idx) 57 | 58 | expr_list <- lapply(par_specs, build_prior_expr) 59 | 60 | body_text <- paste(expr_list, collapse = " + \n") 61 | 62 | body_func <- paste("{", body_text, "}", sep = "\n") 63 | 64 | rlang::new_function(args = rlang::exprs(pars = ), 65 | body = rlang::parse_expr(body_func)) 66 | } 67 | 68 | build_prior_expr <- function(par_obj) { 69 | 70 | dist_name <- par_obj$dist 71 | 72 | arg_names_Stan <- get_dist_args(dist_name) 73 | arg_list <- par_obj[arg_names_Stan] 74 | 75 | arg_names_R <- get_dist_args(dist_name, "R") 76 | dist_args_txt <- paste(arg_names_R, arg_list, sep = " = ") 77 | 78 | fun_name <- Stan_to_R(dist_name, "d") 79 | 80 | par_expr <- constrain_pars(par_obj) 81 | log_arg <- "log = TRUE" 82 | 83 | args_txt <- paste(c(par_expr, dist_args_txt, log_arg), collapse = ", ") 84 | 85 | 86 | stringr::str_glue(" {fun_name}({args_txt})") 87 | 88 | } 89 | 90 | constrain_pars <- function(par_obj) { 91 | 92 | trans_vector <- par_obj$par_trans 93 | idx <- par_obj$index 94 | 95 | par_expr <- stringr::str_glue("pars[[{idx}]]") # unconstrained par 96 | 97 | for(cons in trans_vector) par_expr <- stringr::str_glue("{cons}({par_expr})") 98 | 99 | par_expr 100 | } 101 | -------------------------------------------------------------------------------- /R/interpreters.R: -------------------------------------------------------------------------------- 1 | #' Interpret estimates 2 | #' 3 | #' @param estimates A list or data frame 4 | #' @param par_list A list 5 | #' 6 | #' @return A data frame 7 | #' @export 8 | #' 9 | #' @examples 10 | #' estimates <- c(par_beta = 0, 11 | #' par_rho = 0.8472979, 12 | #' I0 = 0, 13 | #' inv_phi = -2.302585) 14 | #' 15 | #' par_list <- list(list(par_name = "par_beta", 16 | #' par_trans = "exp"), 17 | #' list(par_name = "par_rho", 18 | #' par_trans = "expit"), 19 | #' list(par_name = "I0", 20 | #' par_trans = "exp"), 21 | #' list(par_name = "phi", 22 | #' par_trans = c("exp", "inv"))) 23 | #' sd_interpret_estimates(estimates, par_list) 24 | sd_interpret_estimates <- function(estimates, par_list) { 25 | 26 | if(is.numeric(estimates)) estimate_list <- list(estimates) 27 | 28 | if(is.data.frame(estimates)) estimate_list <- df2list(estimates) 29 | 30 | purrr::map_dfr(estimate_list, decode_estimates, par_list) 31 | } 32 | 33 | decode_estimates <- function(estimate_list, par_list) { 34 | 35 | lapply(seq_along(par_list), function(i) { 36 | 37 | par_obj <- par_list[[i]] 38 | 39 | if(length(par_obj$par_trans) == 1L) val <- do.call(par_obj$par_trans, 40 | list(estimate_list[[i]])) 41 | 42 | if(length(par_obj$par_trans) > 1L) { 43 | 44 | val <- estimate_list[[i]] 45 | 46 | for(j in seq_along(par_obj$par_trans)) { 47 | 48 | val <- do.call(par_obj$par_trans[[j]], list(val)) 49 | } 50 | } 51 | 52 | val <- list(val) 53 | names(val) <- par_obj$par_name 54 | val 55 | }) -> output_list 56 | 57 | data.frame(output_list) 58 | } 59 | 60 | #' Calculate confidence intervals 61 | #' 62 | #' @param hsn Hessian matrix 63 | #' @param conf_level A numeric input indicating the confidence level 64 | #' 65 | #' @inheritParams sd_interpret_estimates 66 | #' 67 | #' @return A data frame. 68 | #' @export 69 | #' 70 | #' @examples 71 | #' estimates <- c(-0.2630303, 1.5788579) 72 | #' par_list <- list(list(par_name = "par_inv_R0", 73 | #' par_trans = "expit"), 74 | #' list(par_name = "I0", 75 | #' par_trans = "exp")) 76 | #' hsn <- matrix(c(3513.10521, -493.5469626, 77 | #' -493.5469626, 88.4871290), ncol = 2) 78 | #' sd_conf_intervals(estimates, par_list, hsn) 79 | sd_conf_intervals <- function(estimates, par_list, hsn, conf_level = 0.95) { 80 | 81 | alpha <- 1 - conf_level 82 | 83 | cov_matrix <- solve(hsn) 84 | 85 | SE <- sqrt(diag(cov_matrix)) # Standard errors 86 | 87 | lower_bounds <- sd_interpret_estimates(estimates + 88 | stats::qnorm(alpha / 2) * SE, 89 | par_list) 90 | 91 | upper_bounds <- sd_interpret_estimates(estimates + 92 | stats::qnorm(1 - alpha / 2) * SE, 93 | par_list) 94 | 95 | df <- data.frame(lb = as.numeric(lower_bounds[1, ,]), 96 | ub = as.numeric(upper_bounds[1, ,])) 97 | 98 | min_max <- apply(df, 1, function(x) c(min(x), max(x))) 99 | 100 | result_df <- data.frame(parameter = colnames(lower_bounds), 101 | lb = min_max[1, ], 102 | ub = min_max[2, ]) 103 | 104 | colnames(result_df) <- c("parameter", 105 | paste0(round(100 * alpha / 2,1), "%"), 106 | paste0(round(100 * (1 - alpha / 2),2), "%")) 107 | 108 | result_df 109 | } 110 | 111 | -------------------------------------------------------------------------------- /R/arrays.R: -------------------------------------------------------------------------------- 1 | array_equations <- function(aux_obj, dims_obj, dim_names, vendor) { 2 | 3 | dims_dict <- dims_obj$dictionary 4 | glob_dims <- dims_obj$global_dims 5 | 6 | n_dims <- length(dim_names) 7 | 8 | dims_list <- lapply(dim_names, function(dim_name) glob_dims[[dim_name]]) 9 | names(dims_list) <- dim_names 10 | elems <- combine_dims(dims_list) 11 | 12 | raw_equation <- aux_obj$equation 13 | aux_name <- aux_obj$name 14 | 15 | if(vendor == "Vensim") { 16 | 17 | vector_pattern <- create_array_pattern(dims_list) 18 | is_an_array <- stringr::str_detect(raw_equation, vector_pattern) 19 | 20 | if(is_an_array) { 21 | 22 | clean_equation <- raw_equation %>% 23 | stringr::str_replace_all(";",",") 24 | 25 | clean_equation <- substr(clean_equation,1, nchar(clean_equation) - 1) 26 | equations <- stringr::str_split(clean_equation, ",")[[1]] 27 | are_const <- !is.na(suppressWarnings(as.numeric(equations))) 28 | } 29 | 30 | if(!is_an_array) { 31 | 32 | devec_eqs <- devectorise_equation(raw_equation, dims_list) 33 | 34 | equations <- sapply(devec_eqs, sanitise_aux_equation, vendor, 35 | USE.NAMES = FALSE) 36 | 37 | are_const <- !is.na(suppressWarnings(as.numeric(equations))) 38 | } 39 | } 40 | 41 | if(vendor == "isee") { 42 | 43 | equations <- sanitise_aux_equation(raw_equation, vendor) 44 | are_const <- !is.na(suppressWarnings(as.numeric(equations))) 45 | 46 | if(!are_const) { 47 | 48 | eq_vars <- extract_variables(lhs = aux_name, equations) 49 | 50 | arrayed_vars <- names(dims_dict) 51 | 52 | for(var_in_eq in eq_vars) { 53 | 54 | if(var_in_eq %in% arrayed_vars) { 55 | 56 | var_dims <- dims_dict[[var_in_eq]] 57 | dims_idx <- paste(var_dims, collapse = ",") 58 | 59 | replacement <- stringr::str_glue("{var_in_eq}[{dims_idx}]") 60 | pattern <- stringr::str_glue("\\b{var_in_eq}\\b") 61 | unvectorised_eq <- stringr::str_replace_all(equations, pattern, 62 | replacement) 63 | devec_eqs <- devectorise_equation(unvectorised_eq, dims_list) 64 | 65 | equations <- sapply(devec_eqs, sanitise_aux_equation, vendor, 66 | USE.NAMES = FALSE) 67 | 68 | are_const <- !is.na(suppressWarnings(as.numeric(equations))) 69 | 70 | } 71 | 72 | } 73 | } 74 | 75 | } 76 | 77 | list(equations = equations, 78 | are_const = are_const, 79 | elems = elems) 80 | } 81 | 82 | 83 | devectorise_equation <- function(raw_equation, dims_list) { 84 | 85 | dim_names <- names(dims_list) 86 | pattern <- paste0("\\[", paste(dim_names, collapse = ","), "\\]") 87 | 88 | elems <- combine_dims(dims_list) 89 | replacement <- paste0("_", elems) 90 | 91 | stringr::str_replace_all(raw_equation, pattern, replacement) 92 | 93 | } 94 | 95 | combine_dims <- function(dims_list) { 96 | 97 | rev_dims_list <- rev(dims_list) 98 | rev_combs_df <- expand.grid(rev_dims_list, stringsAsFactors = FALSE) 99 | combs_df <- rev(rev_combs_df) 100 | do.call(paste, c(combs_df, sep = "_")) 101 | 102 | } 103 | 104 | create_array_pattern <- function(dims_list) { 105 | 106 | n_dims <- length(dims_list) 107 | dim1_length <- length(dims_list[[1]]) 108 | rgx_elems <- rep(".+?", dim1_length) 109 | rgx_array <- paste(rgx_elems, collapse = ",") 110 | 111 | if(n_dims == 2) { 112 | rgx_row <- paste0(rgx_array, ";") 113 | rgx_matrix <- rep(rgx_row, length(dims_list[[2]])) 114 | rgx_array <- paste(rgx_matrix, collapse = "") 115 | } 116 | 117 | rgx_array 118 | 119 | } 120 | -------------------------------------------------------------------------------- /R/if_else_builtins.R: -------------------------------------------------------------------------------- 1 | 2 | #' PULSE TRAIN 3 | #' 4 | #' @param time A numeric argument that indicates the current simulation time 5 | #' @param start_pulse A numeric argument that indicates the start of the pulse 6 | #' @param duration_pulse A numeric argument that indicates the width of the pulse 7 | #' @param repeat_pt A numeric argument that indicates the repetition pattern 8 | #' @param end_pulse A numeric argument that indicates the end of the sequence 9 | #' 10 | #' @return 1 during the pulse, 0 otherwise. 11 | #' @export 12 | #' 13 | #' @examples 14 | #' sd_pulse_train(5, 5, 3, 10, 20) 15 | sd_pulse_train <- function(time, start_pulse, duration_pulse, 16 | repeat_pt, end_pulse) { 17 | 18 | if(time < start_pulse | time > end_pulse) return (0) 19 | 20 | start_candidates <- seq(start_pulse, time, repeat_pt) 21 | pos <- findInterval(time, start_candidates) 22 | optim_start <- start_candidates[pos] # Avoids unnecessary previous intervals 23 | 24 | optim_end <- min(time, end_pulse) # Avoids unnecessary forward intervals 25 | pt_statement <- create_pt_statement(optim_start, duration_pulse, 26 | repeat_pt, optim_end) 27 | 28 | eval(parse(text = pt_statement)) 29 | } 30 | 31 | #' Create Pulse Train statement 32 | #' 33 | #' @param start_pt Numeric 34 | #' @param duration_pt Numeric 35 | #' @param repeat_pt Numeric 36 | #' @param end_pt Numeric 37 | #' 38 | #' @return A string 39 | #' 40 | #' @noRd 41 | create_pt_statement <- function(start_pt, duration_pt, repeat_pt, end_pt) { 42 | 43 | if(duration_pt == 0L) { 44 | 45 | pulse_points <- stringr::str_glue("seq({start_pt}, {end_pt}, {repeat_pt})") 46 | pt_statement <- stringr::str_glue("ifelse(time %in% {pulse_points}, 1, 0)") 47 | return(pt_statement) 48 | } 49 | 50 | intervals_start <- seq(from = start_pt, to = end_pt, by = repeat_pt) 51 | intervals_should_end <- intervals_start + duration_pt 52 | intervals_actual_end <- ifelse(intervals_should_end > end_pt, end_pt, 53 | intervals_should_end) 54 | 55 | comparison_end_intv <- mapply(c, intervals_should_end, intervals_actual_end, 56 | SIMPLIFY = FALSE, USE.NAMES = FALSE) 57 | 58 | conditions <- purrr::map2_chr(intervals_start, comparison_end_intv, ~ { 59 | operator <- ifelse(.y[[1]] == .y[[2]], "<", "<=") 60 | 61 | stringr::str_glue("(time >= {.x} & time {operator} {.y[[2]]})") 62 | }) 63 | 64 | pt_condition <- paste(conditions, collapse = " | ") 65 | stringr::str_glue("ifelse({pt_condition}, 1, 0)") 66 | } 67 | 68 | 69 | #' Replicate the behaviour of the PULSE function from Stella 70 | #' 71 | #' This function must be placed inside the object that will be passed as the 72 | #' argument \code{func} to deSolve's \code{ode} function. 73 | #' 74 | #' @param time A number 75 | #' @param volume A number 76 | #' @param start_p A number 77 | #' @param interval A number 78 | #' 79 | #' @return A number 80 | #' @export 81 | #' 82 | #' @examples 83 | #' timestep <- function() 0.25 # replicates timestep() from deSolve 84 | #' sd_pulse_s(2, 1, 2, 0) 85 | #' 86 | sd_pulse_s <- function(time, volume, start_p, interval) { 87 | pulse_s_statement <- get_pulse_s_statement(volume, start_p, interval) 88 | eval(parse(text = pulse_s_statement)) 89 | } 90 | 91 | #' Replicate the behaviour of the PULSE function from Vensim 92 | #' 93 | #' @param time A number 94 | #' @param startPulse A number 95 | #' @param duration A number 96 | #' 97 | #' @return A number 98 | #' @export 99 | #' 100 | #' @examples 101 | #' timestep <- function() 0.25 # replicates timestep() from deSolve 102 | #' sd_pulse_v(1, 1, 2) 103 | sd_pulse_v <- function(time, startPulse, duration) { 104 | pulse_v_statement <- get_pulse_v_statement(startPulse, duration) 105 | eval(parse(text = pulse_v_statement)) 106 | } 107 | -------------------------------------------------------------------------------- /tests/testthat/test-if_else_builtins.R: -------------------------------------------------------------------------------- 1 | context("sd_pulse_train") 2 | 3 | test_that("sd_pulse_train() returns 1 at the start of the pulse", { 4 | actual_val <- sd_pulse_train(5, 5, 3, 10, 20) 5 | expected_val <- 1 6 | expect_equal(actual_val, expected_val) 7 | }) 8 | 9 | test_that("sd_pulse_train() returns 1 at the middle of the first pulse", { 10 | actual_val <- sd_pulse_train(6.5, 5, 3, 10, 20) 11 | expected_val <- 1 12 | expect_equal(actual_val, expected_val) 13 | }) 14 | 15 | test_that("sd_pulse_train() returns 0 after the end of the first pulse", { 16 | actual_val <- sd_pulse_train(8, 5, 3, 10, 20) 17 | expected_val <- 0 18 | expect_equal(actual_val, expected_val) 19 | }) 20 | 21 | test_that("sd_pulse_train() returns 0 after the sequence end", { 22 | actual_val <- sd_pulse_train(21, 5, 3, 10, 20) 23 | expected_val <- 0 24 | expect_equal(actual_val, expected_val) 25 | }) 26 | 27 | test_that("sd_pulse_train() returns 1 if the interval is cut", { 28 | actual_val <- sd_pulse_train(17, 5, 3, 10, 17) 29 | expected_val <- 1 30 | expect_equal(actual_val, expected_val) 31 | }) 32 | 33 | test_that("sd_pulse_train() returns 0 for non-integer increments", { 34 | actual_val <- sd_pulse_train(6.3, 5, 0, 0.8, 10) 35 | expected_val <- 0 36 | expect_equal(actual_val, expected_val) 37 | }) 38 | 39 | test_that("sd_pulse_train() returns 1 for non-integer increments", { 40 | actual_val <- sd_pulse_train(5.8, 5, 0, 0.8, 10) 41 | expected_val <- 1 42 | expect_equal(actual_val, expected_val) 43 | }) 44 | 45 | test_that("sd_pulse_train() works for intervals of size 0", { 46 | actual_val <- sd_pulse_train(6, 5, 0, 1, 10) 47 | expected_val <- 1 48 | expect_equal(actual_val, expected_val) 49 | }) 50 | 51 | test_that("sd_pulse_train() deals with values after the end ", { 52 | actual_val <- sd_pulse_train(22, 2, 3, 10, 20) 53 | expected_val <- 0 54 | expect_equal(actual_val, expected_val) 55 | }) 56 | 57 | context("create_pt_statement") 58 | 59 | test_that("create_pt_statement() returns the correct condition", { 60 | actual_val <- create_pt_statement(5, 3, 10, 20) 61 | expected_val <- "ifelse((time >= 5 & time < 8) | (time >= 15 & time < 18), 1, 0)" 62 | expect_equal(actual_val, expected_val) 63 | }) 64 | 65 | test_that("create_pt_statement() returns the correct condition when the end of intervals is greater than the end time", { 66 | actual_val <- create_pt_statement(5, 3, 10, 17) 67 | expected_val <- "ifelse((time >= 5 & time < 8) | (time >= 15 & time <= 17), 1, 0)" 68 | expect_equal(actual_val, expected_val) 69 | }) 70 | 71 | test_that("create_pt_statement() deals with intervals equal to 0", { 72 | actual_val <- create_pt_statement(5, 0, 1, 10) 73 | expected_val <- "ifelse(time %in% seq(5, 10, 1), 1, 0)" 74 | expect_equal(actual_val, expected_val) 75 | }) 76 | 77 | # sd_pulse_s =================================================================== 78 | context("sd_pulse_s") 79 | 80 | test_that("sd_pulse_s() returns 1 in an interval equal to zero", { 81 | e <- new.env() 82 | e$timestep <- function() 0.25 83 | environment(sd_pulse_s) <- e 84 | actual_val <- sd_pulse_s(2, 1, 2, 0) 85 | expected_val <- 4 86 | expect_equal(actual_val, expected_val) 87 | }) 88 | 89 | test_that("sd_pulse_s() returns 0 in an interval equal to zero", { 90 | timestep <- function() 0.25 91 | actual_val <- sd_pulse_s(1, 1, 2, 0) 92 | expected_val <- 0 93 | expect_equal(actual_val, expected_val) 94 | }) 95 | 96 | # sd_pulse_v =================================================================== 97 | context("sd_pulse_v") 98 | 99 | test_that("sd_pulse_v() behaves like a pulse from Vensim", { 100 | expect_equal(sd_pulse_v(0, 1, 2), 0) 101 | expect_equal(sd_pulse_v(1, 1, 2), 1) 102 | expect_equal(sd_pulse_v(2, 1, 2), 1) 103 | expect_equal(sd_pulse_v(3, 1, 2), 0) 104 | expect_equal(sd_pulse_v(4, 1, 2), 0) 105 | }) 106 | -------------------------------------------------------------------------------- /tests/testthat/test_stan_files/SEIR_age_pois.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[20] dydt; 6 | real E_to_I_A; 7 | real E_to_I_B; 8 | real E_to_I_C; 9 | real E_to_I_D; 10 | real I_to_R_A; 11 | real I_to_R_B; 12 | real I_to_R_C; 13 | real I_to_R_D; 14 | real total_N; 15 | real var_psi_A; 16 | real var_psi_B; 17 | real var_psi_C; 18 | real var_psi_D; 19 | real C_in_A; 20 | real C_in_B; 21 | real C_in_C; 22 | real C_in_D; 23 | real S_to_E_A; 24 | real S_to_E_B; 25 | real S_to_E_C; 26 | real S_to_E_D; 27 | E_to_I_A = 0.5*y[5]; 28 | E_to_I_B = 0.5*y[6]; 29 | E_to_I_C = 0.5*y[7]; 30 | E_to_I_D = 0.5*y[8]; 31 | I_to_R_A = 0.5*y[9]; 32 | I_to_R_B = 0.5*y[10]; 33 | I_to_R_C = 0.5*y[11]; 34 | I_to_R_D = 0.5*y[12]; 35 | total_N = 264132+614909+2020683+2640994; 36 | var_psi_A = params[1]*y[9]+1.5451053*y[10]+1.0079616*y[11]+0.4403311*y[12]; 37 | var_psi_B = 1.5451053*y[9]+7.2500922*y[10]+1.0689326*y[11]+0.4042651*y[12]; 38 | var_psi_C = 1.0079616*y[9]+1.0689326*y[10]+1.9051576*y[11]+0.8288393*y[12]; 39 | var_psi_D = 0.4403311*y[9]+0.4042651*y[10]+0.8288393*y[11]+0.9137116*y[12]; 40 | C_in_A = params[2]*E_to_I_A; 41 | C_in_B = params[2]*E_to_I_B; 42 | C_in_C = params[2]*E_to_I_C; 43 | C_in_D = params[2]*E_to_I_D; 44 | S_to_E_A = var_psi_A*y[1]/total_N; 45 | S_to_E_B = var_psi_B*y[2]/total_N; 46 | S_to_E_C = var_psi_C*y[3]/total_N; 47 | S_to_E_D = var_psi_D*y[4]/total_N; 48 | dydt[1] = -S_to_E_A; 49 | dydt[2] = -S_to_E_B; 50 | dydt[3] = -S_to_E_C; 51 | dydt[4] = -S_to_E_D; 52 | dydt[5] = S_to_E_A-E_to_I_A; 53 | dydt[6] = S_to_E_B-E_to_I_B; 54 | dydt[7] = S_to_E_C-E_to_I_C; 55 | dydt[8] = S_to_E_D-E_to_I_D; 56 | dydt[9] = E_to_I_A-I_to_R_A; 57 | dydt[10] = E_to_I_B-I_to_R_B; 58 | dydt[11] = E_to_I_C-I_to_R_C; 59 | dydt[12] = E_to_I_D-I_to_R_D; 60 | dydt[13] = I_to_R_A; 61 | dydt[14] = I_to_R_B; 62 | dydt[15] = I_to_R_C; 63 | dydt[16] = I_to_R_D; 64 | dydt[17] = C_in_A; 65 | dydt[18] = C_in_B; 66 | dydt[19] = C_in_C; 67 | dydt[20] = C_in_D; 68 | return dydt; 69 | } 70 | } 71 | data { 72 | int n_obs; 73 | array[n_obs] int y_A; 74 | array[n_obs] int y_B; 75 | array[n_obs] int y_C; 76 | array[n_obs] int y_D; 77 | array[n_obs] real ts; 78 | vector[20] x0; 79 | } 80 | parameters { 81 | real k_AA; 82 | real par_rho; 83 | } 84 | transformed parameters{ 85 | array[n_obs] vector[20] x; // Output from the ODE solver 86 | array[2] real params; 87 | array[n_obs] real delta_x_1; 88 | array[n_obs] real delta_x_2; 89 | array[n_obs] real delta_x_3; 90 | array[n_obs] real delta_x_4; 91 | params[1] = k_AA; 92 | params[2] = par_rho; 93 | x = ode_rk45(X_model, x0, 0, ts, params); 94 | delta_x_1[1] = x[1, 17] - x0[17] + 1e-5; 95 | delta_x_2[1] = x[1, 18] - x0[18] + 1e-5; 96 | delta_x_3[1] = x[1, 19] - x0[19] + 1e-5; 97 | delta_x_4[1] = x[1, 20] - x0[20] + 1e-5; 98 | for (i in 1:n_obs-1) { 99 | delta_x_1[i + 1] = x[i + 1, 17] - x[i, 17] + 1e-5; 100 | delta_x_2[i + 1] = x[i + 1, 18] - x[i, 18] + 1e-5; 101 | delta_x_3[i + 1] = x[i + 1, 19] - x[i, 19] + 1e-5; 102 | delta_x_4[i + 1] = x[i + 1, 20] - x[i, 20] + 1e-5; 103 | } 104 | } 105 | model { 106 | k_AA ~ normal(0, 10); 107 | par_rho ~ beta(2, 2); 108 | y_A ~ poisson(delta_x_1); 109 | y_B ~ poisson(delta_x_2); 110 | y_C ~ poisson(delta_x_3); 111 | y_D ~ poisson(delta_x_4); 112 | } 113 | generated quantities { 114 | real log_lik; 115 | array[n_obs] int sim_y_A; 116 | array[n_obs] int sim_y_B; 117 | array[n_obs] int sim_y_C; 118 | array[n_obs] int sim_y_D; 119 | log_lik = poisson_lpmf(y_A | delta_x_1) + 120 | poisson_lpmf(y_B | delta_x_2) + 121 | poisson_lpmf(y_C | delta_x_3) + 122 | poisson_lpmf(y_D | delta_x_4); 123 | sim_y_A = poisson_rng(delta_x_1); 124 | sim_y_B = poisson_rng(delta_x_2); 125 | sim_y_C = poisson_rng(delta_x_3); 126 | sim_y_D = poisson_rng(delta_x_4); 127 | } 128 | -------------------------------------------------------------------------------- /R/read_xmile.R: -------------------------------------------------------------------------------- 1 | #' Read an XMILE file into R 2 | #' 3 | #'\code{read_xmile} returns a list for constructing deSolve functions and graphs 4 | #' 5 | #' This function extracts the xml from the file specified via \code{filepath} 6 | #' to generate a list of objects. Such a list contains a summary of the model, 7 | #' the inputs for simulating through \link[deSolve]{deSolve}, and the inputs for 8 | #' creating a \link[igraph]{igraph} object. 9 | #' @param filepath A string that indicates a path to a file with extension .stmx 10 | #' or .xmile. Vensim files (.mdl) are not xmile files. They must be exported 11 | #' from Vensim with extension .xmile 12 | #' @param stock_list A list in which each element's name is the name of the 13 | #' stock to override and the element's value correspond to the new init value. 14 | #' 15 | #' @param const_list A list in which each element's name is the name of the 16 | #' constant to override and the element's value correspond to the new value. 17 | #' 18 | #' @param graph A boolean parameter that indicates whether \code{read_xmile} 19 | #' returns a graph for the model. 20 | #' 21 | #' @return This function returns a list with three elements. The first element, 22 | #' \emph{description}, is a list that contains the simulation parameters, and 23 | #' the names and equations (including graphical functions) for each stock or 24 | #' level, variable and constant. The second element, \emph{deSolve_components}, 25 | #' is a list that contains initial values, constants and the function for 26 | #' simulating via deSolve. The third element (optional), \emph{igraph} contains 27 | #' the data.frames for creating a graph with igraph. 28 | #' @export 29 | #' 30 | #' @examples 31 | #' path <- system.file("models", "SIR.stmx", package = "readsdr") 32 | #' read_xmile(path) 33 | read_xmile <- function(filepath, stock_list = NULL, const_list = NULL, 34 | graph = FALSE) { 35 | 36 | model_structure <- extract_structure_from_XMILE(filepath, 37 | const_list = const_list) 38 | 39 | if(!is.null(stock_list)) { 40 | stocks_override <- names(stock_list) 41 | lvl_names <- sapply(model_structure$levels, 42 | function(lvl_obj) lvl_obj$name) 43 | 44 | for(i in seq_len(length(stock_list))) { 45 | stk <- stocks_override[[i]] 46 | pos_stk <- which(stk == lvl_names) 47 | model_structure$levels[[pos_stk]]$initValue <- stock_list[[stk]] 48 | } 49 | } 50 | 51 | deSolve_components <- get_deSolve_elems(model_structure) 52 | 53 | output <- list( 54 | description = model_structure, 55 | deSolve_components = deSolve_components) 56 | 57 | if(graph == TRUE) { 58 | 59 | igraph_inputs <- tryCatch( 60 | error = function(cnd) { 61 | warning("This model cannot be converted into a graph (network)", 62 | call. = FALSE) 63 | NULL 64 | }, 65 | get_igraph_inputs(model_structure) 66 | ) 67 | 68 | output$graph_dfs <- igraph_inputs 69 | } 70 | 71 | output 72 | 73 | } 74 | 75 | #' Parse XMILE to deSolve components 76 | #' 77 | #' \code{xmile_to_deSolve} returns a list that serves as an input for 78 | #' deSolve's ODE function. 79 | #' 80 | #' This function extracts the xml from the file specified via \code{filepath} 81 | #' to generate a list with the necessary elements to simulate with 82 | #' \link[deSolve]{deSolve}. 83 | #' 84 | #' @inheritParams read_xmile 85 | #' 86 | #' @return This function returns a list with at least four elements. 87 | #' \emph{stocks}, a numeric vector that contains initial values. \emph{consts}, 88 | #' a numeric vector with the model's constants. \emph{func}, the function that 89 | #' wraps the model's equations. \emph{sim_params}, a list with control 90 | #' parameters. If the model includes a table or graphical function, this 91 | #' function returns the element \emph{graph_funs}, a list with these functions. 92 | #' 93 | #' @export 94 | #' 95 | #' @examples 96 | #' path <- system.file("models", "SIR.stmx", package = "readsdr") 97 | #' xmile_to_deSolve(path) 98 | xmile_to_deSolve <- function(filepath) { 99 | model_structure <- extract_structure_from_XMILE(filepath) 100 | deSolve_components <- get_deSolve_elems(model_structure) 101 | } 102 | -------------------------------------------------------------------------------- /tests/testthat/test_stan_files/SEIR_age_nbin.stan: -------------------------------------------------------------------------------- 1 | // Code generated by the R package readsdr v0.3.0.9001 2 | // See more info at github https://github.com/jandraor/readsdr 3 | functions { 4 | vector X_model(real time, vector y, array[] real params) { 5 | vector[20] dydt; 6 | real E_to_I_A; 7 | real E_to_I_B; 8 | real E_to_I_C; 9 | real E_to_I_D; 10 | real I_to_R_A; 11 | real I_to_R_B; 12 | real I_to_R_C; 13 | real I_to_R_D; 14 | real total_N; 15 | real var_psi_A; 16 | real var_psi_B; 17 | real var_psi_C; 18 | real var_psi_D; 19 | real C_in_A; 20 | real C_in_B; 21 | real C_in_C; 22 | real C_in_D; 23 | real S_to_E_A; 24 | real S_to_E_B; 25 | real S_to_E_C; 26 | real S_to_E_D; 27 | E_to_I_A = 0.5*y[5]; 28 | E_to_I_B = 0.5*y[6]; 29 | E_to_I_C = 0.5*y[7]; 30 | E_to_I_D = 0.5*y[8]; 31 | I_to_R_A = 0.5*y[9]; 32 | I_to_R_B = 0.5*y[10]; 33 | I_to_R_C = 0.5*y[11]; 34 | I_to_R_D = 0.5*y[12]; 35 | total_N = 264132+614909+2020683+2640994; 36 | var_psi_A = params[1]*y[9]+1.5451053*y[10]+1.0079616*y[11]+0.4403311*y[12]; 37 | var_psi_B = 1.5451053*y[9]+7.2500922*y[10]+1.0689326*y[11]+0.4042651*y[12]; 38 | var_psi_C = 1.0079616*y[9]+1.0689326*y[10]+1.9051576*y[11]+0.8288393*y[12]; 39 | var_psi_D = 0.4403311*y[9]+0.4042651*y[10]+0.8288393*y[11]+0.9137116*y[12]; 40 | C_in_A = params[2]*E_to_I_A; 41 | C_in_B = params[2]*E_to_I_B; 42 | C_in_C = params[2]*E_to_I_C; 43 | C_in_D = params[2]*E_to_I_D; 44 | S_to_E_A = var_psi_A*y[1]/total_N; 45 | S_to_E_B = var_psi_B*y[2]/total_N; 46 | S_to_E_C = var_psi_C*y[3]/total_N; 47 | S_to_E_D = var_psi_D*y[4]/total_N; 48 | dydt[1] = -S_to_E_A; 49 | dydt[2] = -S_to_E_B; 50 | dydt[3] = -S_to_E_C; 51 | dydt[4] = -S_to_E_D; 52 | dydt[5] = S_to_E_A-E_to_I_A; 53 | dydt[6] = S_to_E_B-E_to_I_B; 54 | dydt[7] = S_to_E_C-E_to_I_C; 55 | dydt[8] = S_to_E_D-E_to_I_D; 56 | dydt[9] = E_to_I_A-I_to_R_A; 57 | dydt[10] = E_to_I_B-I_to_R_B; 58 | dydt[11] = E_to_I_C-I_to_R_C; 59 | dydt[12] = E_to_I_D-I_to_R_D; 60 | dydt[13] = I_to_R_A; 61 | dydt[14] = I_to_R_B; 62 | dydt[15] = I_to_R_C; 63 | dydt[16] = I_to_R_D; 64 | dydt[17] = C_in_A; 65 | dydt[18] = C_in_B; 66 | dydt[19] = C_in_C; 67 | dydt[20] = C_in_D; 68 | return dydt; 69 | } 70 | } 71 | data { 72 | int n_obs; 73 | array[n_obs] int y_A; 74 | array[n_obs] int y_B; 75 | array[n_obs] int y_C; 76 | array[n_obs] int y_D; 77 | array[n_obs] real ts; 78 | vector[20] x0; 79 | } 80 | parameters { 81 | real k_AA; 82 | real par_rho; 83 | real inv_phi; 84 | } 85 | transformed parameters{ 86 | array[n_obs] vector[20] x; // Output from the ODE solver 87 | array[2] real params; 88 | array[n_obs] real delta_x_1; 89 | array[n_obs] real delta_x_2; 90 | array[n_obs] real delta_x_3; 91 | array[n_obs] real delta_x_4; 92 | real phi; 93 | phi = 1 / inv_phi; 94 | params[1] = k_AA; 95 | params[2] = par_rho; 96 | x = ode_rk45(X_model, x0, 0, ts, params); 97 | delta_x_1[1] = x[1, 17] - x0[17] + 1e-5; 98 | delta_x_2[1] = x[1, 18] - x0[18] + 1e-5; 99 | delta_x_3[1] = x[1, 19] - x0[19] + 1e-5; 100 | delta_x_4[1] = x[1, 20] - x0[20] + 1e-5; 101 | for (i in 1:n_obs-1) { 102 | delta_x_1[i + 1] = x[i + 1, 17] - x[i, 17] + 1e-5; 103 | delta_x_2[i + 1] = x[i + 1, 18] - x[i, 18] + 1e-5; 104 | delta_x_3[i + 1] = x[i + 1, 19] - x[i, 19] + 1e-5; 105 | delta_x_4[i + 1] = x[i + 1, 20] - x[i, 20] + 1e-5; 106 | } 107 | } 108 | model { 109 | k_AA ~ normal(0, 10); 110 | par_rho ~ beta(2, 2); 111 | inv_phi ~ exponential(5); 112 | y_A ~ neg_binomial_2(delta_x_1, phi); 113 | y_B ~ neg_binomial_2(delta_x_2, phi); 114 | y_C ~ neg_binomial_2(delta_x_3, phi); 115 | y_D ~ neg_binomial_2(delta_x_4, phi); 116 | } 117 | generated quantities { 118 | real log_lik; 119 | array[n_obs] int sim_y_A; 120 | array[n_obs] int sim_y_B; 121 | array[n_obs] int sim_y_C; 122 | array[n_obs] int sim_y_D; 123 | log_lik = neg_binomial_2_lpmf(y_A | delta_x_1, phi) + 124 | neg_binomial_2_lpmf(y_B | delta_x_2, phi) + 125 | neg_binomial_2_lpmf(y_C | delta_x_3, phi) + 126 | neg_binomial_2_lpmf(y_D | delta_x_4, phi); 127 | sim_y_A = neg_binomial_2_rng(delta_x_1, phi); 128 | sim_y_B = neg_binomial_2_rng(delta_x_2, phi); 129 | sim_y_C = neg_binomial_2_rng(delta_x_3, phi); 130 | sim_y_D = neg_binomial_2_rng(delta_x_4, phi); 131 | } 132 | -------------------------------------------------------------------------------- /tests/testthat/test-SBC.R: -------------------------------------------------------------------------------- 1 | test_that("sd_data_generator_fun() returns the expected function", { 2 | 3 | filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 4 | 5 | meas_mdl <- list("y ~ poisson(net_flow(C))") 6 | 7 | estimated_params <- list( 8 | sd_prior("par_beta", "lognormal", c(0, 1)), 9 | sd_prior("par_rho", "beta", c(2, 2)), 10 | sd_prior("I0", "lognormal", c(0, 1), "init")) 11 | 12 | actual_fun <- sd_data_generator_fun(filepath, estimated_params, meas_mdl, 13 | start_time = 0, stop_time = 10, 14 | timestep = 1/32, integ_method = "rk4") 15 | 16 | set.seed(200) 17 | actual_list <- actual_fun() 18 | 19 | expected <- list( 20 | variables = list( 21 | par_beta = 1.088452, 22 | par_rho = 0.5636847, 23 | I0 = 1.541193), 24 | generated = list( 25 | y = c(0, 0, 0, 0, 1, 1, 0, 2, 2, 2), 26 | n_obs = 10, 27 | n_params = 2, 28 | n_difeq = 5, 29 | t0 = 0, 30 | ts = 1:10)) 31 | 32 | expect_equal(actual_list, expected, tolerance = 1e-6) 33 | 34 | # Negative Binomial test 35 | meas_mdl <- list("y ~ neg_binomial_2(net_flow(C), phi)") 36 | 37 | estimated_params <- list( 38 | sd_prior("par_beta", "lognormal", c(0, 1)), 39 | sd_prior("par_rho", "beta", c(2, 2)), 40 | sd_prior("I0", "lognormal", c(0, 1), "init")) 41 | 42 | actual_fun <- sd_data_generator_fun(filepath, estimated_params, meas_mdl, 43 | start_time = 0, stop_time = 10, 44 | timestep = 1/32, integ_method = "rk4") 45 | 46 | set.seed(300) 47 | actual_list <- actual_fun() 48 | 49 | expected <- list( 50 | variables = list( 51 | par_beta = 3.950297, 52 | par_rho = 0.7321697, 53 | I0 = 1.605586, 54 | inv_phi = 0.1033722), 55 | generated = list( 56 | y = c(3, 3, 15, 19, 71, 155, 332, 193, 803, 2453), 57 | n_obs = 10, 58 | n_params = 2, 59 | n_difeq = 5, 60 | t0 = 0, 61 | ts = 1:10)) 62 | 63 | expect_equal(actual_list, expected, tolerance = 1e-6) 64 | }) 65 | 66 | test_that("sd_data_generator_fun() returns the expected function for a vectorised model", { 67 | 68 | filepath <- system.file("models/", "SEIR_age.stmx", package = "readsdr") 69 | 70 | ag <- c("A", "B", "C", "D") # age_groups 71 | 72 | measurements <- stringr::str_glue("y_{ag} ~ poisson(net_flow(C_{ag}))") 73 | meas_mdl <- as.list(measurements) 74 | 75 | estimated_params <- list( 76 | sd_prior("k_AA", "normal", c(0, 10), min = 0), 77 | sd_prior("par_rho", "beta", c(2, 2))) 78 | 79 | actual_fun <- sd_data_generator_fun(filepath, estimated_params, meas_mdl, 80 | start_time = 0, stop_time = 10, 81 | timestep = 1/32, integ_method = "rk4") 82 | 83 | set.seed(111) 84 | actual_list <- actual_fun() 85 | 86 | expected <- list( 87 | variables = list( 88 | k_AA = 2.352207, 89 | par_rho = 0.4073203), 90 | generated = list( 91 | y_A = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 92 | y_B = c(0, 0, 0, 1, 0, 0, 0, 0, 0, 0), 93 | y_C = c(1, 0, 0, 0, 1, 0, 0, 0, 0, 1), 94 | y_D = c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2), 95 | n_obs = 10, 96 | n_params = 2, 97 | n_difeq = 20, 98 | t0 = 0, 99 | ts = 1:10)) 100 | 101 | expect_equal(actual_list, expected, tolerance = 1e-6) 102 | 103 | }) 104 | 105 | test_that("prior_fun_factory() returns the expected list of functions", { 106 | 107 | estimated_params <- list( 108 | sd_prior("par_beta", "lognormal", c(0, 1)), 109 | sd_prior("par_rho", "beta", c(2, 2)), 110 | sd_prior("I0", "lognormal", c(0, 1), "init")) 111 | 112 | fun_list <- prior_fun_factory(estimated_params, 1) 113 | 114 | set.seed(123) 115 | 116 | val1 <- fun_list[[1]]() 117 | val2 <- fun_list[[2]]() 118 | val3 <- fun_list[[3]]() 119 | 120 | actual <- c(val1, val2, val3) 121 | 122 | factory1 <- function() function() rlnorm(1) 123 | factory2 <- function() function() rbeta(1, 2, 2) 124 | 125 | fun1 <- factory1() 126 | fun2 <- factory2() 127 | fun3 <- factory1() 128 | 129 | set.seed(123) 130 | 131 | val1 <- fun1() 132 | val2 <- fun2() 133 | val3 <- fun3() 134 | 135 | expected <- c(val1, val2, val3) 136 | 137 | expect_equal(actual, expected) 138 | }) 139 | -------------------------------------------------------------------------------- /R/impact_inputs.R: -------------------------------------------------------------------------------- 1 | 2 | #' Construct inputs for performing structural analysis via the impact method 3 | #' 4 | #' @param desc_list Element 'description' from the list returned by \code{read_xmile()} 5 | #' 6 | #' @return A list of three elements. The first element, \code{flows}, is a data 7 | #' frame that lists all the stock-flow links in the model. Further, this data 8 | #' frame describes the equation that governs the link and whether the link is 9 | #' an inflow (+) or an outflow (-). The second element, \code{pathways}, is a 10 | #' data frame that lists all the pathways among stocks. The third element, 11 | #' \code{velocities}, is a data frame in which each row corresponds to a 12 | #' stock. Each row consists of two columns (name & equation). 13 | #' @export 14 | #' 15 | #' @examples 16 | #' filepath <- system.file("models/", "SIR.stmx", package = "readsdr") 17 | #' mdl <- read_xmile(filepath) 18 | #' desc_list <- mdl$description 19 | #' sd_impact_inputs(desc_list) 20 | sd_impact_inputs <- function(desc_list) { 21 | 22 | flows_df <- flow_equations(desc_list) 23 | pathways_df <- pathways(flows_df) 24 | velocities_df <- velocity_equations(desc_list) 25 | 26 | list(flows = flows_df, 27 | pathways = pathways_df, 28 | velocities = velocities_df) 29 | } 30 | 31 | # Construct velocity equations in terms of stocks and constants 32 | velocity_equations <- function(desc_list) { 33 | 34 | levels <- desc_list$levels 35 | stock_names <- purrr::map_chr(levels, "name") 36 | 37 | consts <- desc_list$constants 38 | const_names <- purrr::map_chr(consts, "name") 39 | 40 | var_obj <- desc_list$variables 41 | 42 | elem_names <- c(stock_names, const_names) 43 | 44 | equations <- purrr::map_chr(levels, construct_velocity_equation, 45 | elem_names, var_obj) 46 | 47 | 48 | data.frame(stock = stock_names, equation = equations) 49 | } 50 | 51 | construct_velocity_equation <- function(lvl_obj, elem_names, var_obj) { 52 | 53 | lvl_name <- lvl_obj$name 54 | equation <- lvl_obj$equation 55 | 56 | disentangle_equation(lvl_name, equation, elem_names, var_obj) 57 | } 58 | 59 | disentangle_equation <- function(lvl_name, equation, elem_names, var_obj) { 60 | 61 | var_names <- purrr::map_chr(var_obj, "name") 62 | elems_rhs <- extract_variables(lvl_name, equation) 63 | validation <- sum(!(elems_rhs %in% elem_names)) 64 | 65 | if(validation == 0) return(equation) 66 | 67 | if(validation > 0) { 68 | 69 | auxs <- elems_rhs[!(elems_rhs %in% elem_names)] 70 | 71 | for(i in seq_along(auxs)) { 72 | 73 | aux <- auxs[i] 74 | pos_aux <- which(var_names == aux) 75 | aux_eq <- var_obj[[pos_aux]]$equation 76 | aux_eq <- stringr::str_glue("({aux_eq})") 77 | regex_pattern <- stringr::regex(paste0("\\b", aux,"\\b")) 78 | equation <- stringr::str_replace_all(equation, regex_pattern, aux_eq) 79 | } 80 | 81 | disentangle_equation(lvl_name, equation, elem_names, var_obj) 82 | 83 | } 84 | } 85 | 86 | flow_equations <- function(desc_list) { 87 | 88 | levels <- desc_list$levels 89 | lvl_names <- purrr::map_chr(levels, "name") 90 | 91 | consts <- desc_list$constants 92 | const_names <- purrr::map_chr(consts, "name") 93 | 94 | elem_names <- c(lvl_names, const_names) 95 | 96 | var_obj <- desc_list$variables 97 | 98 | purrr::map_df(desc_list$levels, function(lvl_obj) { 99 | 100 | lvl_name <- lvl_obj$name 101 | stock_col <- data.frame(stock = lvl_name) 102 | cbind(stock_col, decompose_net_flow(lvl_obj$equation)) 103 | }) -> flow_df 104 | 105 | flow_list <- purrr::transpose(flow_df) 106 | 107 | sapply(flow_list, function(flow_obj) { 108 | disentangle_equation(flow_obj$stock, flow_obj$flow, elem_names, var_obj) 109 | }) -> eqs 110 | 111 | flow_df$equation <- eqs 112 | 113 | flow_df 114 | } 115 | 116 | decompose_net_flow <- function(flow_eq) { 117 | 118 | val <- stringr::str_starts(flow_eq, "-", negate = TRUE) 119 | 120 | if(val) flow_eq <- paste0("+", flow_eq) 121 | 122 | flows <- extract_variables("", flow_eq) 123 | signs <- stringr::str_extract_all(flow_eq, "\\+|\\-")[[1]] 124 | 125 | data.frame(flow = flows, sign = signs) 126 | } 127 | 128 | pathways <- function(flows_df) { 129 | 130 | lvl_names <- unique(flows_df$stock) 131 | flows_list <- purrr::transpose(flows_df) 132 | 133 | purrr::map_df(flows_list, function(flow_obj) { 134 | 135 | to <- flow_obj$stock 136 | through <- flow_obj$flow 137 | flow_vars <- extract_variables(to, flow_obj$equation) 138 | from <- flow_vars[flow_vars %in% lvl_names] 139 | 140 | data.frame(from = from, to = to, through = through) 141 | }) 142 | } 143 | -------------------------------------------------------------------------------- /tests/testthat/test-generate_igraph_inputs.R: -------------------------------------------------------------------------------- 1 | context("Generate igraph inputs") 2 | 3 | structure_m1 <- list( 4 | parameters = NULL, 5 | levels = list( 6 | list(name = "Population", 7 | equation = "net_growth", 8 | initValue = 100) 9 | ), 10 | variables = list( 11 | list(name = "net_growth", 12 | equation = "Population*growth_rate") 13 | ), 14 | constants = list( 15 | list(name = "growth_rate", 16 | value = 0.01) 17 | )) 18 | 19 | #get_igraph_inputs()------------------------------------------------------------ 20 | 21 | test_that("get_igraph_inputs() returns the expected elements", { 22 | expect_named(get_igraph_inputs(structure_m1), c("nodes", "edges")) 23 | }) 24 | 25 | test_that("get_igraph_inputs() valid inputs for igraph", { 26 | graph_dfs <- get_igraph_inputs(structure_m1) 27 | 28 | gr <- igraph::graph_from_data_frame(graph_dfs$edges, directed = T, 29 | vertices = graph_dfs$nodes) 30 | expect_is(gr, "igraph") 31 | }) 32 | 33 | 34 | 35 | stocks <- list(list(name = "population", 36 | equation = "births", 37 | initValue = 100)) 38 | 39 | 40 | variables <- list(list(name = "births", equation = "population*birthRate"), 41 | list(name = "birthRate", equation = "birthRate2")) 42 | 43 | constants <- list(list(name = "birthRate2", value = 0.1)) 44 | 45 | stocks2 <- stocks 46 | variables2 <- list(list(name = "births", equation = "population*birthRate")) 47 | constants2 <- list(list(name = "birthRate", value = 0.1)) 48 | 49 | # generate_edges_df()----------------------------------------------------------- 50 | 51 | test_that("generate_edges_df() returns the correct number of edges", { 52 | e_df <- with(structure_m1, generate_edges_df(levels, variables, constants)) 53 | expect_equal(nrow(e_df), 2) 54 | }) 55 | 56 | test_that("generate_edges_df() returns the correct number of flows", { 57 | e_df <- with(structure_m1, generate_edges_df(levels, variables, constants)) 58 | e_df <- e_df[e_df$type == "flow", ] 59 | expect_equal(nrow(e_df), 1) 60 | }) 61 | 62 | test_that("generate_edges_df() ignores info-links whose tail is a constant", { 63 | edges_df <- generate_edges_df(stocks, variables, constants) 64 | expect_equal(nrow(edges_df), 3) 65 | }) 66 | 67 | # generate_nodes_df()----------------------------------------------------------- 68 | 69 | test_that("generate_nodes_df() returns a df with the correct columns", { 70 | actual_val <- with(structure_m1, 71 | generate_nodes_df(levels, variables, constants)) 72 | 73 | expect_named(actual_val, c("name", "type", "equation")) 74 | }) 75 | 76 | test_that("generate_nodes_df() returns the correct number of nodes", { 77 | df <- with(structure_m1, generate_nodes_df(levels, variables, constants)) 78 | expect_equal(nrow(df), 2) 79 | }) 80 | 81 | test_that("generate_nodes_df() replaces auxiliar consts with their value in equations", { 82 | nodes_df <- generate_nodes_df(stocks2, variables2, constants2) 83 | expect_equal(nodes_df[[2, "equation"]], "population*0.1") 84 | }) 85 | 86 | test_that("generate_nodes_df() throws an error should a variable directly 87 | depends on time", { 88 | 89 | variables <- list( 90 | list(name = "net_growth", 91 | equation = "ifelse(time>1Population*growth_rate,0)") 92 | ) 93 | expect_error( 94 | generate_nodes_df(structure_m1$levels, variables, structure_m1$constants), 95 | "A variable depends on time") 96 | }) 97 | 98 | # construct_var_edge()---------------------------------------------------------- 99 | 100 | test_that("construct_var_edge() ignores scalars in equations", { 101 | var_obj <- list(name = "w", 102 | equation = "x*y/(k+1/z)") 103 | 104 | const_names_test <- c("k") 105 | actual <- construct_var_edge(var_obj, const_names_test) 106 | expected <- data.frame(from = c("x", "y", "z"), to = "w", type = "info_link", 107 | stringsAsFactors = FALSE) 108 | expect_equal(actual, expected) 109 | }) 110 | 111 | test_that("construct_var_edge() accounts for repeated variables", { 112 | var_obj <- list(name = "z", 113 | equation = "(x+y)/x") 114 | 115 | const_names_test <- c("k") 116 | actual <- construct_var_edge(var_obj, const_names_test) 117 | expected <- data.frame(from = c("x", "y"), to = "z", type = "info_link", 118 | stringsAsFactors = FALSE) 119 | expect_equal(actual, expected) 120 | }) 121 | 122 | # construct_stock_edge()-------------------------------------------------------- 123 | 124 | test_that('construct_stock_edge returns NULL constant-alike stocks', { 125 | stock_obj <- list(name = "test_stock", 126 | equation = "0") 127 | expect_equal(construct_stock_edge(stock_obj), NULL) 128 | } ) 129 | -------------------------------------------------------------------------------- /R/SBC.R: -------------------------------------------------------------------------------- 1 | #' Function factory for SBC 2 | #' @return A function. 3 | #' @export 4 | 5 | #' @inheritParams read_xmile 6 | #' @inheritParams sd_Bayes 7 | #' @inheritParams sd_simulate 8 | #' @examples 9 | #' filepath <- system.file("models/", "SEIR.stmx", package = "readsdr") 10 | #' meas_mdl <- list("y ~ poisson(net_flow(C))") 11 | #' estimated_params <- list( 12 | #' sd_prior("par_beta", "lognormal", c(0, 1)), 13 | #' sd_prior("par_rho", "beta", c(2, 2)), 14 | #' sd_prior("I0", "lognormal", c(0, 1), "init")) 15 | #' sd_data_generator_fun(filepath, estimated_params, meas_mdl) 16 | sd_data_generator_fun <- function(filepath, estimated_params, meas_mdl, 17 | start_time = NULL, 18 | stop_time = NULL, 19 | timestep = NULL, 20 | integ_method = "euler") { 21 | 22 | pars_names <- get_names(estimated_params, "par_name") 23 | 24 | estimated_params <- get_meas_params(meas_mdl, estimated_params) 25 | 26 | prior_fun_list <- prior_fun_factory(estimated_params, 1) 27 | 28 | mdl_structure <- extract_structure_from_XMILE(filepath, pars_names) 29 | ds_inputs <- get_deSolve_elems(mdl_structure) 30 | 31 | if(!(integ_method %in% c("euler", "rk4"))) stop("Invalid integration method") 32 | 33 | ds_inputs <- update_sim_params(ds_inputs, start_time, stop_time, timestep) 34 | 35 | n_stocks <- length(ds_inputs$stocks) 36 | 37 | unk_types <- sapply(estimated_params, function(prior_obj) prior_obj$type) 38 | n_consts <- sum(unk_types == "constant") 39 | 40 | idx_meas <- which(unk_types == "meas_par") 41 | n_meas_par <- length(idx_meas) 42 | 43 | data_fun <- function() { 44 | 45 | prior_vals <- lapply(prior_fun_list, function(prior_fun) prior_fun()) 46 | 47 | for(param in pars_names) ds_inputs$consts[[param]] <- prior_vals[[param]] 48 | 49 | readsdr_env <- list2env(prior_vals) 50 | 51 | ds_inputs$stocks <- purrr::map_dbl(ds_inputs$stocks, function(x) { 52 | 53 | eval(parse(text = x), envir = readsdr_env) 54 | }) 55 | 56 | if(n_meas_par > 0) { 57 | 58 | meas_params <- estimated_params[idx_meas] 59 | 60 | for(meas_par_obj in meas_params) { 61 | 62 | # Parameter's name before the transformation 63 | before_name <- stringr::str_remove(meas_par_obj$par_name, 64 | paste0(meas_par_obj$par_trans, "_")) 65 | 66 | trans_value <- execute_trans(prior_vals[[meas_par_obj$par_name]], 67 | meas_par_obj$par_trans) 68 | 69 | meas_mdl <- lapply(meas_mdl, function(meas_obj) { 70 | 71 | stringr::str_replace(meas_obj, before_name, 72 | as.character(trans_value)) 73 | }) 74 | } 75 | } 76 | 77 | measurement_df <- sd_measurements(1, meas_mdl, ds_inputs, 78 | start_time = start_time, 79 | stop_time = stop_time, 80 | timestep = timestep, 81 | integ_method = integ_method) 82 | 83 | n_obs <- length(unique(measurement_df$time)) 84 | 85 | split_df <- split(measurement_df, measurement_df$var_name) 86 | meas_list <- lapply(split_df, function(df) df$measurement) 87 | names(meas_list) <- unique(measurement_df$var_name) 88 | 89 | specs_list <- list( 90 | n_obs = n_obs, 91 | n_params = n_consts, 92 | n_difeq = n_stocks, 93 | t0 = 0, 94 | ts = 1:n_obs) 95 | 96 | list(variables = prior_vals, 97 | generated = c(meas_list, specs_list)) 98 | } 99 | } 100 | 101 | prior_fun_factory <- function(estimated_params, n_draws) { 102 | 103 | n_params <- length(estimated_params) 104 | 105 | fun_list <- vector("list", n_params) 106 | 107 | for (i in 1:n_params) { 108 | 109 | par_obj <- estimated_params[[i]] 110 | 111 | dist_name <- par_obj$dist 112 | 113 | arg_names_R <- get_dist_args(dist_name, "R") 114 | arg_names_Stan <- get_dist_args(dist_name) 115 | arg_list <- par_obj[arg_names_Stan] 116 | 117 | fun_name <- Stan_to_R(dist_name) 118 | 119 | fun_list[[i]] <- fun_factory(fun_name, arg_names_R, arg_list, n_draws) 120 | names(fun_list)[i] <- par_obj$par_name 121 | } 122 | 123 | fun_list 124 | } 125 | 126 | fun_factory <- function(fun_name, arg_names_R, arg_list, n_draws) { 127 | 128 | dist_args_txt <- paste(arg_names_R, arg_list, sep = " = ") 129 | n_arg <- paste0("n = ", n_draws) 130 | args_txt <- paste(c(n_arg, dist_args_txt), collapse = ", ") 131 | body_fun <- stringr::str_glue("{fun_name}({args_txt })") 132 | 133 | rlang::new_function(args = NULL, body = rlang::parse_expr(body_fun)) 134 | } 135 | -------------------------------------------------------------------------------- /tests/testthat/test_models/SEIR_simlin.stmx: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | SEIR 5 | Simlin 6 | Simlin 7 |
8 | 9 | 0 10 | 100 11 |
0.015625
12 | 13 | 14 | 15 | 16 | 9999 17 | s_to_e 18 | 19 | 20 | 0 21 | s_to_e 22 | e_to_i 23 | 24 | 25 | 1 26 | e_to_i 27 | i_to_r 28 | 29 | 30 | 0 31 | i_to_r 32 | 33 | 34 | par_beta * s * i / n 35 | 36 | 37 | par_sigma * e 38 | 39 | 40 | par_gamma * i 41 | 42 | 43 | 10000 44 | 45 | 46 | 1 47 | 48 | 49 | 0.5 50 | 51 | 52 | 0.5 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | s 81 | s to e 82 | 83 | 84 | i 85 | s to e 86 | 87 | 88 | 89 | n 90 | s to e 91 | 92 | 93 | 94 | par beta 95 | s to e 96 | 97 | 98 | e 99 | e to i 100 | 101 | 102 | i 103 | i to r 104 | 105 | 106 | 107 | par gamma 108 | i to r 109 | 110 | 111 | 112 | par sigma 113 | e to i 114 | 115 | 116 | 117 | 118 | --------------------------------------------------------------------------------