├── .dockerignore ├── .github ├── .gitignore └── workflows │ ├── make-release.yaml │ ├── pkgdown.yaml │ ├── test-coverage.yaml │ └── R-CMD-check.yaml ├── .eslintignore ├── inst ├── template │ ├── DESCRIPTION │ ├── NAMESPACE │ └── odin_c.R ├── examples │ ├── package │ │ ├── NAMESPACE │ │ ├── DESCRIPTION │ │ └── inst │ │ │ └── odin │ │ │ └── lorenz.R │ ├── logistic.R │ ├── lorenz.R │ ├── discrete_deterministic_sir.R │ ├── discrete_stochastic_sir.R │ ├── discrete_stochastic_sir_arrays.R │ └── discrete_stochastic_seirds.R ├── js │ ├── test-continuous.js │ ├── test-discrete.js │ ├── dust-rng.js │ └── README.md ├── WORDLIST ├── LICENSE.random └── LICENSE.dopri ├── tests ├── testthat │ ├── identity.c │ ├── user_fns.R │ ├── user_fns.js │ ├── pkg │ │ ├── NAMESPACE │ │ ├── inst │ │ │ └── odin │ │ │ │ ├── discretedelay.R │ │ │ │ └── pulse.R │ │ └── DESCRIPTION │ ├── user_fns.c │ ├── user_fns2.c │ ├── user_fns3.c │ ├── user_fns4.c │ ├── helper-discrete.R │ ├── examples │ │ ├── interpolate_odin.R │ │ ├── lorenz_odin.R │ │ ├── lv4_odin.R │ │ ├── sir_odin.R │ │ ├── sir_bm.txt │ │ ├── interpolate_deSolve.R │ │ ├── lorenz_deSolve.R │ │ ├── lv4_deSolve.R │ │ ├── sir_deSolve.R │ │ ├── seir_odin.R │ │ ├── seir_bm.txt │ │ ├── seir_deSolve.R │ │ ├── array_bm.txt │ │ ├── array_odin_user3.R │ │ ├── array_odin_user.R │ │ ├── array_odin_user2.R │ │ ├── array_odin.R │ │ ├── array_2d_odin.R │ │ ├── seir_array_odin.R │ │ ├── array_deSolve.R │ │ └── seir_array_deSolve.R │ ├── stochastic │ │ ├── sir_discrete.R │ │ ├── sir_discrete_stochastic.R │ │ ├── sir_discrete_stochastic2.R │ │ └── sir_discrete_stochastic_multi.R │ ├── helper-parse.R │ ├── test-js-support.R │ ├── test-generate-c.R │ ├── test-generate-r.R │ ├── test-ir.R │ ├── test-odin-options.R │ ├── test-parse2-stochastic.R │ ├── logs │ │ ├── gcc_warnings.txt │ │ └── gcc_error.txt │ ├── helper-examples.R │ ├── test-run-regression.R │ ├── helper-differentiate.R │ ├── test-can-compile.R │ ├── random.js │ ├── test-ring-cache.R │ ├── test-js-wrapper.R │ ├── test-odin-validate.R │ ├── test-odin-build.R │ ├── helper-package.R │ ├── test-parse2-differentiate.R │ ├── test-run-debug.R │ ├── test-parse2-interpolation.R │ ├── helper-js.R │ ├── test-parse-inplace.R │ ├── test-parse2-delay.R │ ├── test-opt.R │ ├── test-parse2-unused.R │ ├── test-parse2-data.R │ ├── test-preprocess.R │ ├── test-parse2-config.R │ ├── helper-odin.R │ └── test-parse2-debug.R └── testthat.R ├── man ├── figures │ └── logo.png ├── odin_js_versions.Rd ├── odin_ir_deserialise.Rd ├── odin_ir.Rd ├── odin_js_bundle.Rd ├── can_compile.Rd ├── odin_parse.Rd ├── odin_package.Rd ├── odin_build.Rd ├── odin_validate.Rd └── odin_options.Rd ├── LICENSE ├── .gitattributes ├── scripts ├── create_support_sum_js.R ├── ir-build.R ├── update_web.sh └── update_js ├── R ├── zzz.R ├── ir_validate.R ├── compat.R ├── ir_substitute.R ├── can_compile.R ├── ir_parse_error.R ├── generate_r_utils.R ├── js_bundle.R ├── generate_r_sexp.R ├── ring_cache.R ├── interface.R ├── odin_parse.R ├── misc.R ├── debug.R ├── ir_deserialise.R ├── generate_js_util.R ├── odin_validate.R ├── odin_preprocess.R ├── odin_build.R ├── generate_c.R ├── opt.R ├── generate_c_support.R ├── dependencies.R ├── generate_c_utils.R ├── ir_parse_config.R ├── differentiate-support.R ├── generate_c_sexp.R └── odin_options.R ├── docker ├── bin │ ├── install_remote │ └── install_packages ├── build └── Dockerfile ├── .lintr ├── .gitignore ├── .Rbuildignore ├── NAMESPACE ├── development.md ├── Makefile └── DESCRIPTION /.dockerignore: -------------------------------------------------------------------------------- 1 | .git 2 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.eslintignore: -------------------------------------------------------------------------------- 1 | inst/js/random.js 2 | inst/js/dopri.js 3 | -------------------------------------------------------------------------------- /inst/template/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: {{package}} 2 | Version: 0.0.1 3 | -------------------------------------------------------------------------------- /inst/template/NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib("{{package}}", .registration = TRUE) 2 | -------------------------------------------------------------------------------- /tests/testthat/identity.c: -------------------------------------------------------------------------------- 1 | double identity(double x) { 2 | return x; 3 | } 4 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrc-ide/odin/HEAD/man/figures/logo.png -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(odin) 3 | 4 | test_check("odin") 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2019 2 | COPYRIGHT HOLDER: Imperial College of Science, Technology and Medicine 3 | -------------------------------------------------------------------------------- /tests/testthat/user_fns.R: -------------------------------------------------------------------------------- 1 | squarepulse <- function(t, t0, t1) { 2 | t >= t0 && t < t1 3 | } 4 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | inst/js/odin.js linguist-vendored=true 2 | inst/js/dust.js linguist-vendored=true 3 | -------------------------------------------------------------------------------- /tests/testthat/user_fns.js: -------------------------------------------------------------------------------- 1 | function squarepulse(t, t0, t1) { 2 | return t >= t0 && t < t1; 3 | } 4 | -------------------------------------------------------------------------------- /tests/testthat/pkg/NAMESPACE: -------------------------------------------------------------------------------- 1 | # exportPattern("^[^\\.]") 2 | useDynLib("%s") 3 | importFrom("odin", "odin") 4 | -------------------------------------------------------------------------------- /tests/testthat/pkg/inst/odin/discretedelay.R: -------------------------------------------------------------------------------- 1 | initial(y) <- 1 2 | update(y) <- y + yprev 3 | yprev <- delay(y, 1) 4 | -------------------------------------------------------------------------------- /inst/examples/package/NAMESPACE: -------------------------------------------------------------------------------- 1 | # exportPattern("^[^\\.]") 2 | useDynLib(odin.example) 3 | importFrom("odin", "odin") 4 | -------------------------------------------------------------------------------- /tests/testthat/user_fns.c: -------------------------------------------------------------------------------- 1 | double squarepulse(double t, double t0, double t1) { 2 | return t >= t0 && t < t1; 3 | } 4 | -------------------------------------------------------------------------------- /inst/examples/logistic.R: -------------------------------------------------------------------------------- 1 | deriv(N) <- r * N * (1 - N / K) 2 | initial(N) <- N0 3 | 4 | N0 <- 1 5 | K <- 100 6 | r <- 0.5 7 | -------------------------------------------------------------------------------- /tests/testthat/pkg/inst/odin/pulse.R: -------------------------------------------------------------------------------- 1 | config(include) <- "user_fns.c" 2 | z <- squarepulse(t, 1, 2) 3 | output(z) <- z 4 | deriv(y) <- z 5 | initial(y) <- 0 6 | -------------------------------------------------------------------------------- /tests/testthat/user_fns2.c: -------------------------------------------------------------------------------- 1 | double squarepulse(double t, 2 | double t0, 3 | double t1) { 4 | return t >= t0 && t < t1; 5 | } 6 | -------------------------------------------------------------------------------- /tests/testthat/user_fns3.c: -------------------------------------------------------------------------------- 1 | double squarepulse(double t, 2 | double t0, 3 | double t1) { 4 | return t >= t0 && t < t1; 5 | } 6 | -------------------------------------------------------------------------------- /scripts/create_support_sum_js.R: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | devtools::load_all() 3 | code <- unlist(lapply(2:8, generate_js_support_sum)) 4 | writeLines(code, "inst/js/support_sum.js") 5 | -------------------------------------------------------------------------------- /tests/testthat/user_fns4.c: -------------------------------------------------------------------------------- 1 | // A little example function that uses a vector. 2 | double f(size_t i, double *x) { 3 | double n = 0; 4 | for (size_t j = 0; j < i; ++j) { 5 | n += x[j]; 6 | } 7 | return n; 8 | } 9 | -------------------------------------------------------------------------------- /tests/testthat/helper-discrete.R: -------------------------------------------------------------------------------- 1 | logistic_map <- function(r, y, t) { 2 | ret <- matrix(0, t + 1, length(y)) 3 | ret[1, ] <- y 4 | for (i in seq_len(t)) { 5 | ret[i + 1, ] <- y <- r * y * (1 - y) 6 | } 7 | ret 8 | } 9 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .odin <- new.env(parent = emptyenv()) 2 | 3 | 4 | .onLoad <- function(libname, pkgname) { 5 | .odin$version <- utils::packageVersion("odin") 6 | .odin$model_cache_c <- R6_ring_cache$new(getOption("odin.cache_size", 30L)) 7 | } 8 | -------------------------------------------------------------------------------- /inst/js/test-continuous.js: -------------------------------------------------------------------------------- 1 | function call_odin_bundle(Model, pars, tStart, tEnd, nPoints, control) { 2 | const solution = odinjs.wodinRun(Model, pars, tStart, tEnd, control); 3 | return solution({mode: "grid", tStart, tEnd, nPoints}); 4 | } 5 | -------------------------------------------------------------------------------- /inst/js/test-discrete.js: -------------------------------------------------------------------------------- 1 | function call_odin_bundle(Model, pars, tStart, tEnd, dt, nParticles) { 2 | const solution = dust.wodinRunDiscrete(Model, pars, tStart, tEnd, dt, nParticles); 3 | return solution({mode: "grid", tStart, tEnd, nPoints: Infinity}); 4 | } 5 | -------------------------------------------------------------------------------- /docker/bin/install_remote: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 'Usage: 3 | install_remote [--repos=REPO...] ...' -> usage 4 | opts <- docopt::docopt(usage) 5 | 6 | options(repos = c(opts$repos, getOption("repos"))) 7 | spec <- opts$spec 8 | 9 | remotes::install_github(spec) 10 | -------------------------------------------------------------------------------- /tests/testthat/pkg/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: %s 2 | Title: Example Odin Models 3 | Version: 0.1.0 4 | Description: Example Odin models. 5 | Depends: R (>= 3.2.3) 6 | License: CC0 7 | Author: Rich FitzJohn 8 | Maintainer: Rich FitzJohn 9 | Imports: odin 10 | -------------------------------------------------------------------------------- /.lintr: -------------------------------------------------------------------------------- 1 | linters: linters_with_defaults( 2 | indentation_linter = NULL, 3 | object_name_linter = NULL, 4 | object_length_linter = NULL, 5 | object_usage_linter = NULL, 6 | cyclocomp_linter = NULL 7 | ) 8 | exclusions: list("tests/testthat.R", "inst/template/odin_c.R") 9 | -------------------------------------------------------------------------------- /inst/examples/package/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: odin.example 2 | Title: Example Odin Models 3 | Version: 0.1.0 4 | Description: Example Odin models. 5 | Depends: R (>= 3.2.3) 6 | License: CC0 7 | Author: Rich FitzJohn 8 | Maintainer: Rich FitzJohn 9 | Imports: odin 10 | -------------------------------------------------------------------------------- /inst/examples/lorenz.R: -------------------------------------------------------------------------------- 1 | deriv(y1) <- sigma * (y2 - y1) 2 | deriv(y2) <- R * y1 - y2 - y1 * y3 3 | deriv(y3) <- -b * y3 + y1 * y2 4 | 5 | initial(y1) <- 10.0 6 | initial(y2) <- 1.0 7 | initial(y3) <- 1.0 8 | 9 | ## These are the classical parameters: 10 | sigma <- 10 11 | R <- 28 12 | b <- 8 / 3 13 | -------------------------------------------------------------------------------- /tests/testthat/examples/interpolate_odin.R: -------------------------------------------------------------------------------- 1 | deriv(C) <- flux - kk * C 2 | initial(C) <- C0 3 | flux <- interpolate(flux_t, flux_y, "linear") 4 | C0 <- user() 5 | kk <- user() 6 | output(deposition) <- kk * C 7 | flux_t[] <- user() 8 | flux_y[] <- user() 9 | dim(flux_t) <- user() 10 | dim(flux_y) <- user() 11 | -------------------------------------------------------------------------------- /inst/examples/package/inst/odin/lorenz.R: -------------------------------------------------------------------------------- 1 | deriv(y1) <- sigma * (y2 - y1) 2 | deriv(y2) <- R * y1 - y2 - y1 * y3 3 | deriv(y3) <- -b * y3 + y1 * y2 4 | 5 | initial(y1) <- 10.0 6 | initial(y2) <- 1.0 7 | initial(y3) <- 1.0 8 | 9 | ## These are the classical parameters: 10 | sigma <- 10 11 | R <- 28 12 | b <- 8 / 3 13 | -------------------------------------------------------------------------------- /tests/testthat/stochastic/sir_discrete.R: -------------------------------------------------------------------------------- 1 | update(S) <- S - beta * S * I / N 2 | update(I) <- I + beta * S * I / N - gamma * I 3 | update(R) <- R + gamma * I 4 | 5 | initial(S) <- S0 6 | initial(I) <- 10 7 | initial(R) <- 0 8 | 9 | S0 <- user(100) 10 | beta <- user(0.1) 11 | gamma <- user(0.1) 12 | 13 | N <- S + I + R 14 | -------------------------------------------------------------------------------- /tests/testthat/helper-parse.R: -------------------------------------------------------------------------------- 1 | ## When creating test cases for the parser, we need to create model 2 | ## systems that include initial() and deriv()/update() calls 3 | ex <- function(x, discrete = FALSE, var = "q") { 4 | rhs <- if (discrete) "update" else "deriv" 5 | sprintf("%s\ninitial(%s) <- 1\n%s(%s) <- 1", x, var, rhs, var) 6 | } 7 | -------------------------------------------------------------------------------- /tests/testthat/examples/lorenz_odin.R: -------------------------------------------------------------------------------- 1 | ## Derivatives 2 | deriv(y1) <- sigma * (y2 - y1) 3 | deriv(y2) <- R * y1 - y2 - y1 * y3 4 | deriv(y3) <- -b * y3 + y1 * y2 5 | 6 | ## Initial conditions 7 | initial(y1) <- 10.0 8 | initial(y2) <- 1.0 9 | initial(y3) <- 1.0 10 | 11 | ## parameters 12 | sigma <- 10.0 13 | R <- 28.0 14 | b <- 8.0 / 3.0 15 | -------------------------------------------------------------------------------- /tests/testthat/examples/lv4_odin.R: -------------------------------------------------------------------------------- 1 | deriv(y[]) <- r[i] * y[i] * (1 - sum(ay[i, ])) 2 | initial(y[]) <- y0[i] 3 | 4 | y0[] <- user() 5 | r[] <- user() 6 | a[, ] <- user() 7 | ay[, ] <- a[i, j] * y[j] 8 | 9 | dim(r) <- user() 10 | n_spp <- length(r) 11 | 12 | dim(y) <- n_spp 13 | dim(y0) <- n_spp 14 | dim(a) <- c(n_spp, n_spp) 15 | dim(ay) <- c(n_spp, n_spp) 16 | -------------------------------------------------------------------------------- /inst/js/dust-rng.js: -------------------------------------------------------------------------------- 1 | // A small js rng that we can seed via R. Some faff is required here 2 | // because we need to serialise the returned values carefully to avoid 3 | // jsonlite truncating them to a few significant figures 4 | { 5 | random: function() { 6 | return JSON.parse(console.r.call("function() jsonlite::toJSON(runif(1), digits = NA, auto_unbox = TRUE)", [])); 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /scripts/ir-build.R: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | devtools::load_all() 3 | path <- "tests/testthat/ir" 4 | re_ext <- "\\.R$" 5 | files <- dir(path, full.names = TRUE, pattern = re_ext) 6 | options <- odin_options(pretty = FALSE, validate = TRUE) 7 | for (f in files) { 8 | message(f) 9 | ir <- suppressMessages(ir_parse(f, options)) 10 | writeLines(ir, sub(re_ext, ".json", f)) 11 | } 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Meta 2 | doc 3 | .Rproj.user 4 | .Rhistory 5 | .RData 6 | tests/testthat/examples/*.rds 7 | tests/testthat/examples/malaria_* 8 | issues.md 9 | tests/testthat/*.c 10 | tests/testthat/tmp* 11 | inst/doc 12 | inst/web 13 | tests/testthat/interpolate/Makevars 14 | tests/testthat/joel.R 15 | tests/testthat/joel 16 | tests/testthat/eugene 17 | .valgrind_ignore 18 | docs 19 | *~ 20 | TODO.md 21 | build/ 22 | .V8history 23 | -------------------------------------------------------------------------------- /tests/testthat/examples/sir_odin.R: -------------------------------------------------------------------------------- 1 | deriv(S) <- Births - b * S - beta * S * I / N + delta * R 2 | deriv(I) <- beta * S * I / N - (b + sigma) * I 3 | deriv(R) <- sigma * I - b * R - delta * R 4 | 5 | initial(S) <- N - I0 6 | initial(I) <- I0 7 | initial(R) <- 0 8 | 9 | Births <- N / 75 10 | b <- 1 / 75 11 | N <- 1e7 12 | I0 <- user(1) 13 | beta <- user(24) 14 | sigma <- 12 15 | delta <- 1 / 5 16 | 17 | config(base) <- "sir" 18 | -------------------------------------------------------------------------------- /tests/testthat/test-js-support.R: -------------------------------------------------------------------------------- 1 | test_that("can create functions", { 2 | expect_equal( 3 | js_function(c("a"), "return 1;"), 4 | c("function(a) {", " return 1;", "}")) 5 | expect_equal( 6 | js_function(c("a"), "return 1;", "constructor"), 7 | c("constructor(a) {", " return 1;", "}")) 8 | expect_equal( 9 | js_function(c("a"), "return 1;", "name"), 10 | c("function name(a) {", " return 1;", "}")) 11 | }) 12 | -------------------------------------------------------------------------------- /docker/bin/install_packages: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 'Usage: 3 | install_packages [--repo=REPO...] ...' -> usage 4 | opts <- docopt::docopt(usage) 5 | 6 | repos <- opts$repo 7 | packages <- opts$package 8 | 9 | options(repos = c(repos, getOption("repos"))) 10 | install.packages(packages) 11 | 12 | msg <- setdiff(packages, .packages(TRUE)) 13 | if (length(msg) > 0L) { 14 | stop("Failed to install: ", paste(msg, collapse = ", ")) 15 | } 16 | -------------------------------------------------------------------------------- /tests/testthat/examples/sir_bm.txt: -------------------------------------------------------------------------------- 1 | ; From Hannah Slater, 2016-02-05 2 | METHOD RK4 3 | 4 | STARTTIME = 0 5 | STOPTIME=100 6 | DT = 0.01 7 | YEARS = TIME 8 | 9 | d/dt( S ) = Births - b*S - beta*S*I/N + delta*R 10 | d/dt( I ) = beta*S*I/N - (b+sigma)*I 11 | d/dt( R ) = sigma*I - b*R-delta*R 12 | 13 | init S = N - I0 14 | init I = I0 15 | init R = 0 16 | 17 | Births = N/75 18 | b = 1/75 19 | N = 1e7 20 | I0 = 1 21 | beta = 24 22 | sigma = 12 23 | delta = 1/5 24 | -------------------------------------------------------------------------------- /tests/testthat/examples/interpolate_deSolve.R: -------------------------------------------------------------------------------- 1 | interpolate <- function() { 2 | flux <- NULL 3 | k <- NULL 4 | C0 <- NULL 5 | initial <- function(t = 1, pars = NULL) { 6 | flux <<- approxfun(pars$flux_t, pars$flux_y) 7 | k <<- pars$k 8 | C0 <<- mean(flux(1:365)) / k 9 | C0 10 | } 11 | 12 | derivs <- function(t, y, .) { 13 | flux_t <- flux(t) 14 | list(flux_t - k * y) 15 | } 16 | 17 | list(derivs = derivs, initial = initial, t = c(1, 365)) 18 | } 19 | -------------------------------------------------------------------------------- /docker/build: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -e 3 | HERE=$(dirname $0) 4 | ODIN_ROOT=$(realpath $HERE/..) 5 | 6 | GIT_SHA=$(git rev-parse --short=7 HEAD) 7 | GIT_BRANCH=$(git symbolic-ref --short HEAD) 8 | if [ $GIT_BRANCH == "master" ]; then 9 | GIT_BRANCH="latest" 10 | fi 11 | 12 | TAG_SHA="mrcide/odin:${GIT_SHA}" 13 | TAG_BRANCH="mrcide/odin:${GIT_BRANCH}" 14 | 15 | docker build \ 16 | -f docker/Dockerfile \ 17 | -t "$TAG_SHA" \ 18 | -t "$TAG_BRANCH" \ 19 | $ODIN_ROOT 20 | -------------------------------------------------------------------------------- /scripts/update_web.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | 4 | DOCS_DIR=docs 5 | VERSION=$(git rev-parse --short HEAD) 6 | REMOTE_URL=$(git config --get remote.origin.url) 7 | 8 | rm -rf ${DOCS_DIR}/.git 9 | git init ${DOCS_DIR} 10 | git -C ${DOCS_DIR} checkout --orphan gh-pages 11 | git -C ${DOCS_DIR} add . 12 | git -C ${DOCS_DIR} commit --no-verify -m "Update docs for version ${VERSION}" 13 | git -C ${DOCS_DIR} remote add origin -m "gh-pages" ${REMOTE_URL} 14 | git -C ${DOCS_DIR} push --force -u origin gh-pages 15 | -------------------------------------------------------------------------------- /tests/testthat/examples/lorenz_deSolve.R: -------------------------------------------------------------------------------- 1 | sir <- function() { 2 | sigma <- 10.0 3 | R <- 28.0 4 | b <- 8.0 / 3.0 5 | 6 | initial <- function(t = 0, pars = NULL) { 7 | c(10, 1, 1) 8 | } 9 | 10 | derivs <- function(t, y, .) { 11 | y1 <- y[[1L]] 12 | y2 <- y[[2L]] 13 | y3 <- y[[3L]] 14 | list(c(sigma * (y2 - y1), 15 | R * y1 - y2 - y1 * y3, 16 | -b * y3 + y1 * y2)) 17 | } 18 | 19 | list(derivs = derivs, initial = initial, t = c(0, 15)) 20 | } 21 | -------------------------------------------------------------------------------- /tests/testthat/test-generate-c.R: -------------------------------------------------------------------------------- 1 | context("generate: c (tools)") 2 | 3 | test_that("Integer sums over arrays not supported", { 4 | data <- list(elements = list(y = list(storage_type = "int"))) 5 | expect_error( 6 | generate_c_sexp(list("sum", "y", 1, 2), data, list(), character()), 7 | "Partial integer sums not yet supported") 8 | data$elements$y$storage_type <- "double" 9 | expect_equal( 10 | generate_c_sexp(list("sum", "y", 1, 2), data, list(), character()), 11 | "odin_sum1(y, 0, 2)") 12 | }) 13 | -------------------------------------------------------------------------------- /tests/testthat/stochastic/sir_discrete_stochastic.R: -------------------------------------------------------------------------------- 1 | update(S) <- S - n_SI 2 | update(I) <- I + n_SI - n_IR 3 | update(R) <- R + n_IR 4 | 5 | initial(S) <- S0 6 | initial(I) <- 10 7 | initial(R) <- 0 8 | 9 | p_SI <- 1 - exp(-beta * I / N) 10 | p_IR <- 1 - exp(-gamma) 11 | 12 | n_SI <- rbinom(S, p_SI) 13 | n_IR <- rbinom(I, p_IR) 14 | 15 | ## If order of operations matter 16 | ## > S1 <- S + .... 17 | ## > update(S) <- S1 18 | 19 | S0 <- user(100) 20 | beta <- user(0.1) 21 | gamma <- user(0.1) 22 | 23 | N <- S + I + R 24 | -------------------------------------------------------------------------------- /man/odin_js_versions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/js.R 3 | \name{odin_js_versions} 4 | \alias{odin_js_versions} 5 | \title{Report JS versions} 6 | \usage{ 7 | odin_js_versions() 8 | } 9 | \value{ 10 | A named list of \link{package_version} versions, for \code{odinjs} 11 | and other components used in the JavaScript support. 12 | } 13 | \description{ 14 | Report versions of JavaScript packages used to run odin models. 15 | } 16 | \examples{ 17 | odin::odin_js_versions() 18 | } 19 | -------------------------------------------------------------------------------- /tests/testthat/test-generate-r.R: -------------------------------------------------------------------------------- 1 | context("generate: r (tools)") 2 | 3 | 4 | ## Because we put the scalar variables into the packing first, they 5 | ## never trigger the language branch of this function. But that's 6 | ## something that could in theory change. 7 | test_that("r_offset_to_position", { 8 | expect_equal(r_offset_to_position(0), 1) 9 | expect_equal(r_offset_to_position(10), 11) 10 | expect_equal(r_offset_to_position(quote(x)), quote(x + 1L)) 11 | expect_equal(r_offset_to_position(quote(f(x))), quote(f(x) + 1L)) 12 | }) 13 | -------------------------------------------------------------------------------- /tests/testthat/examples/lv4_deSolve.R: -------------------------------------------------------------------------------- 1 | lv4 <- function() { 2 | r <- NULL 3 | a <- NULL 4 | 5 | initial <- function(t = 0, pars = NULL) { 6 | r <<- pars[["r"]] 7 | a <<- pars[["a"]] 8 | pars[["y0"]] 9 | } 10 | 11 | derivs <- function(t, y, .) { 12 | ## Not much faster, less clear: 13 | ## > list(r * y * (1 - colSums(t(a) * y))) 14 | list(vapply(seq_along(y), function(i) { 15 | r[i] * y[i] * (1 - sum(a[i, ] * y)) 16 | }, numeric(1))) 17 | } 18 | 19 | list(derivs = derivs, initial = initial, t = c(0, 100)) 20 | } 21 | -------------------------------------------------------------------------------- /inst/examples/discrete_deterministic_sir.R: -------------------------------------------------------------------------------- 1 | ## Core equations for transitions between compartments: 2 | update(S) <- S - beta * S * I / N 3 | update(I) <- I + beta * S * I / N - gamma * I 4 | update(R) <- R + gamma * I 5 | 6 | ## Total population size (odin will recompute this at each timestep: 7 | ## automatically) 8 | N <- S + I + R 9 | 10 | ## Initial states: 11 | initial(S) <- S_ini # will be user-defined 12 | initial(I) <- I_ini # will be user-defined 13 | initial(R) <- 0 14 | 15 | ## User defined parameters - default in parentheses: 16 | S_ini <- user(1000) 17 | I_ini <- user(1) 18 | beta <- user(0.2) 19 | gamma <- user(0.1) 20 | -------------------------------------------------------------------------------- /tests/testthat/stochastic/sir_discrete_stochastic2.R: -------------------------------------------------------------------------------- 1 | update(S[]) <- S[i] - n_SI[i] 2 | update(I[]) <- I[i] + n_SI[i] - n_IR[i] 3 | update(R[]) <- R[i] + n_IR[i] 4 | 5 | initial(S[]) <- S0 6 | initial(I[]) <- 10 7 | initial(R[]) <- 0 8 | 9 | p_SI[] <- 1 - exp(-beta * I[i] / N[i]) 10 | p_IR <- 1 - exp(-gamma) 11 | 12 | n_SI[] <- rbinom(S[i], p_SI[i]) 13 | n_IR[] <- rbinom(I[i], p_IR) 14 | 15 | S0 <- user(100) 16 | beta <- user(0.1) 17 | gamma <- user(0.1) 18 | 19 | N[] <- S[i] + I[i] + R[i] 20 | 21 | nsim <- user(100) 22 | dim(N) <- nsim 23 | dim(S) <- nsim 24 | dim(I) <- nsim 25 | dim(R) <- nsim 26 | dim(p_SI) <- nsim 27 | dim(n_SI) <- nsim 28 | dim(n_IR) <- nsim 29 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^Meta$ 2 | ^doc$ 3 | ^.*\.Rproj$ 4 | ^\.Rproj\.user$ 5 | ^Makefile$ 6 | ^README.Rmd$ 7 | ^.travis.yml$ 8 | ^appveyor.yml$ 9 | ^tests/testthat/examples/.*\.rds$ 10 | ^tests/testthat/.*\.o 11 | ^tests/testthat/.*\.so$ 12 | ^inst/.*\.o 13 | ^inst/.*\.so$ 14 | ^tests/testthat/examples/malaria_.*$ 15 | ^inst/web$ 16 | ^odin_.*\.tar.gz$ 17 | ^odin\.Rcheck$ 18 | ^ignore$ 19 | ^notes\.md$ 20 | ^issues\.md$ 21 | ^tests/testthat/joel$ 22 | ^tests/testthat/eugene$ 23 | ^appveyor\.yml$ 24 | ^\.valgrind_ignore$ 25 | ^docs$ 26 | ^scripts$ 27 | ^TODO\.md$ 28 | ^development\.md$ 29 | ^docker$ 30 | ^\.dockerignore$ 31 | ^\.github$ 32 | ^\.lintr$ 33 | ^\.eslintignore$ 34 | ^js$ 35 | ^\.V8history$ 36 | -------------------------------------------------------------------------------- /tests/testthat/examples/sir_deSolve.R: -------------------------------------------------------------------------------- 1 | sir <- function() { 2 | N <- 1e7 3 | Births <- N / 75 4 | b <- 1 / 75 5 | I0 <- 1 6 | beta <- 24 7 | sigma <- 12 8 | delta <- 1 / 5 9 | 10 | initial <- function(t = 0, pars = NULL) { 11 | if ("I0" %in% names(pars)) { 12 | I0 <<- pars$I0 13 | } 14 | c(N - I0, I0, 0.0) 15 | } 16 | 17 | derivs <- function(t, y, .) { 18 | S <- y[[1L]] 19 | I <- y[[2L]] 20 | R <- y[[3L]] 21 | list(c(Births - b * S - beta * S * I / N + delta * R, 22 | beta * S * I / N - (b + sigma) * I, 23 | sigma * I - b * R - delta * R)) 24 | } 25 | 26 | list(derivs = derivs, initial = initial, t = c(0, 100)) 27 | } 28 | -------------------------------------------------------------------------------- /R/ir_validate.R: -------------------------------------------------------------------------------- 1 | ir_validate <- function(x, error = FALSE) { 2 | ir_validate_against_schema(x, error) 3 | } 4 | 5 | 6 | ir_validate_against_schema <- function(x, error) { 7 | if (is.null(.odin$validator)) { 8 | .odin$validator <- ir_validate_create_validator() 9 | } 10 | .odin$validator(x, verbose = TRUE, greedy = TRUE, error = error) 11 | } 12 | 13 | 14 | ir_validate_create_validator <- function() { 15 | path <- odin_file("schema.json") 16 | schema <- read_string(path) 17 | 18 | ## We get somewhat better errors from jsonlite's parsers than hoping 19 | ## that the json is valid. 20 | jsonlite::fromJSON(schema) 21 | 22 | jsonvalidate::json_validator(schema, engine = "ajv") 23 | } 24 | -------------------------------------------------------------------------------- /tests/testthat/test-ir.R: -------------------------------------------------------------------------------- 1 | context("ir") 2 | 3 | test_that("deserialise", { 4 | code <- c("initial(x) <- 1", "deriv(x) <- 1") 5 | ir <- odin_parse_(code, type = "text") 6 | expect_error(odin_ir_deserialise(as.character(ir)), 7 | "Expected a json string") 8 | 9 | res <- odin_ir_deserialise(ir) 10 | expect_identical(res$ir, ir) 11 | }) 12 | 13 | 14 | test_that("Stage information included in IR", { 15 | ir <- odin_parse_("examples/array_odin.R", 16 | options = odin_options(rewrite_constants = FALSE)) 17 | dat <- odin_ir_deserialise(ir) 18 | expect_equal(dat$data$elements$N_age$stage, "constant") 19 | expect_equal(dat$data$elements$I_tot$stage, "time") 20 | }) 21 | -------------------------------------------------------------------------------- /tests/testthat/test-odin-options.R: -------------------------------------------------------------------------------- 1 | context("odin_options") 2 | 3 | test_that("odin_options creates a classed list", { 4 | opts <- odin_options() 5 | expect_s3_class(opts, "odin_options") 6 | expect_true(is.list(opts)) 7 | }) 8 | 9 | test_that("can create placeholder handler for include parsing", { 10 | opts <- odin_options(target = "fortran") 11 | expect_error( 12 | opts$read_include(), 13 | "'config(include)' is not supported for target 'fortran'", fixed = TRUE) 14 | }) 15 | 16 | 17 | test_that("manually set parsing functions persist", { 18 | opts <- odin_options(target = "fortran") 19 | opts$read_include <- read_include_c 20 | expect_identical(odin_options(options = opts)$read_include, read_include_c) 21 | }) 22 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-stochastic.R: -------------------------------------------------------------------------------- 1 | context("parse: stochastic") 2 | 3 | test_that("disallow stochastic functions in ODEs", { 4 | ## Here's a stochastic random walk: 5 | expect_error(odin_parse({ 6 | initial(x) <- 0 7 | deriv(x) <- x + norm_rand() 8 | }), "Stochastic functions not allowed in ODE models", class = "odin_error") 9 | }) 10 | 11 | 12 | ## This is not allowed directly, though we may allow some via a two 13 | ## step process perhaps. 14 | test_that("disallow stochastic functions on array rhs", { 15 | expect_error( 16 | odin_parse({ 17 | initial(x[]) <- 1 18 | dim(x) <- 10 19 | update(x[runif(1, 10)]) <- 2 20 | }), 21 | "Invalid array use on lhs", class = "odin_error") 22 | }) 23 | -------------------------------------------------------------------------------- /inst/examples/discrete_stochastic_sir.R: -------------------------------------------------------------------------------- 1 | ## Core equations for transitions between compartments: 2 | update(S) <- S - n_SI 3 | update(I) <- I + n_SI - n_IR 4 | update(R) <- R + n_IR 5 | 6 | ## Individual probabilities of transition: 7 | p_SI <- 1 - exp(-beta * I / N) # S to I 8 | p_IR <- 1 - exp(-gamma) # I to R 9 | 10 | ## Draws from binomial distributions for numbers changing between 11 | ## compartments: 12 | n_SI <- rbinom(S, p_SI) 13 | n_IR <- rbinom(I, p_IR) 14 | 15 | ## Total population size 16 | N <- S + I + R 17 | 18 | ## Initial states: 19 | initial(S) <- S_ini 20 | initial(I) <- I_ini 21 | initial(R) <- 0 22 | 23 | ## User defined parameters - default in parentheses: 24 | S_ini <- user(1000) 25 | I_ini <- user(1) 26 | beta <- user(0.2) 27 | gamma <- user(0.1) 28 | -------------------------------------------------------------------------------- /tests/testthat/examples/seir_odin.R: -------------------------------------------------------------------------------- 1 | initial(S) <- N - I0 2 | initial(E) <- 0 3 | initial(I) <- I0 4 | initial(R) <- 0 5 | 6 | I0 <- 1 7 | 8 | Births <- b * N 9 | b <- 1 / 10 10 | N <- 1e7 11 | beta <- 10 12 | sigma <- 1 / 3 13 | delta <- 1 / 21 14 | lat_hum <- 14 15 | 16 | ## people developing latent infection 17 | new_inf <- beta * S * I / N 18 | ## i.e. proportion of humans surviving the latent period 19 | surv <- exp(-b * lat_hum) 20 | ## people that become latent 'lath_um' days ago, less those that died 21 | ## during that time 22 | lag_inf <- delay(new_inf * surv, lat_hum) 23 | 24 | deriv(S) <- Births - b * S - new_inf + delta * R 25 | deriv(E) <- new_inf - lag_inf - b * E 26 | deriv(I) <- lag_inf - (b + sigma) * I 27 | deriv(R) <- sigma * I - b * R - delta * R 28 | -------------------------------------------------------------------------------- /tests/testthat/logs/gcc_warnings.txt: -------------------------------------------------------------------------------- 1 | gcc -std=gnu99 -I/usr/share/R/include -DNDEBUG -fpic -Wall -Wextra -Wno-unused-parameter -O2 -c odin741363c295f8.c -o odin741363c295f8.o 2 | odin741363c295f8.c: In function ‘odin741363c295f8_deriv’: 3 | odin741363c295f8.c:62:32: warning: suggest parentheses around ‘&&’ within ‘||’ [-Wparentheses] 4 | output[2] = t > 8 || t > 1 && t < 3; 5 | ^ 6 | odin741363c295f8.c: In function ‘odin741363c295f8_output’: 7 | odin741363c295f8.c:71:30: warning: suggest parentheses around ‘&&’ within ‘||’ [-Wparentheses] 8 | output[2] = t > 8 || t > 1 && t < 3; 9 | ^ 10 | gcc -std=gnu99 -shared -L/usr/lib/R/lib -Wl,-Bsymbolic-functions -Wl,-z,relro -o odin741363c295f8.so odin741363c295f8.o -L/usr/lib/R/lib -lR 11 | -------------------------------------------------------------------------------- /tests/testthat/examples/seir_bm.txt: -------------------------------------------------------------------------------- 1 | ; From Hannah Slater, 2016-02-09 2 | METHOD RK4 3 | 4 | STARTTIME = 0 5 | STOPTIME=365 6 | DT = 0.01 7 | 8 | init S = N - 1 9 | init E = 0 10 | init I =1 11 | init R = 0 12 | 13 | Births = b*N 14 | b = 1/10 15 | N = 1e7 16 | beta = 10 17 | sigma = 1/3 18 | delta = 1/21 19 | lat_hum = 14 20 | 21 | new_inf = beta*S*I/N ; people developing latent infection 22 | surv = exp(-b*lat_hum) ; i.e. proportion of humans surviving the latent period 23 | lag_inf = delay(new_inf * surv, lat_hum) ; people that become latent 'lath_um' days ago, less those that died during that time 24 | 25 | d/dt( S ) = Births - b*S - beta*S*I/N+delta*R 26 | d/dt( E ) = new_inf - lag_inf - b*E 27 | d/dt( I ) = lag_inf - (b+sigma)*I 28 | d/dt( R ) = sigma*I - b*R-delta*R 29 | 30 | Ntot =S+E+I+R 31 | prev = I/Ntot*100 32 | -------------------------------------------------------------------------------- /.github/workflows/make-release.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | 6 | name: make-release 7 | 8 | jobs: 9 | create-release: 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - uses: actions/checkout@v3 14 | 15 | - name: Extract version 16 | run: | 17 | echo "PACKAGE_VERSION=$(grep '^Version' DESCRIPTION | sed 's/.*: *//')" >> $GITHUB_ENV 18 | echo "PACKAGE_NAME=$(grep '^Package' DESCRIPTION | sed 's/.*: *//')" >> $GITHUB_ENV 19 | 20 | - name: Create Release 21 | id: create_release 22 | uses: softprops/action-gh-release@v1 23 | with: 24 | tag_name: v${{ env.PACKAGE_VERSION }} 25 | release_name: Release ${{ env.PACKAGE_NAME }} ${{ env.PACKAGE_VERSION }} 26 | draft: false 27 | prerelease: false 28 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("$",odin_generator) 4 | S3method("[[",odin_generator) 5 | S3method(.DollarNames,odin_generator) 6 | S3method(coef,odin_generator) 7 | S3method(coef,odin_js_generator) 8 | S3method(coef,odin_model) 9 | S3method(print,odin_generator) 10 | export(can_compile) 11 | export(odin) 12 | export(odin_) 13 | export(odin_build) 14 | export(odin_ir) 15 | export(odin_ir_deserialise) 16 | export(odin_js_bundle) 17 | export(odin_js_versions) 18 | export(odin_options) 19 | export(odin_package) 20 | export(odin_parse) 21 | export(odin_parse_) 22 | export(odin_validate) 23 | importFrom(R6,R6Class) 24 | importFrom(cinterpolate,interpolation_function) 25 | importFrom(deSolve,dede) 26 | importFrom(deSolve,ode) 27 | importFrom(stats,coef) 28 | importFrom(stats,rhyper) 29 | importFrom(stats,setNames) 30 | importFrom(utils,.DollarNames) 31 | -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM rocker/r-ver:4.0.3 2 | 3 | RUN apt-get update && apt-get -y install --no-install-recommends \ 4 | git \ 5 | libcurl4-openssl-dev \ 6 | libssl-dev \ 7 | libv8-dev \ 8 | libxml2-dev \ 9 | zlib1g-dev \ 10 | && apt-get clean \ 11 | && rm -rf /var/lib/apt/lists/* 12 | 13 | COPY docker/bin /usr/local/bin/ 14 | 15 | RUN install_packages --repo=https://mrc-ide.github.io/drat \ 16 | R6 \ 17 | dde \ 18 | cinterpolate \ 19 | deSolve \ 20 | devtools \ 21 | digest \ 22 | glue \ 23 | jsonlite \ 24 | jsonvalidate \ 25 | knitr \ 26 | mockery \ 27 | pkgbuild \ 28 | pkgload \ 29 | ring \ 30 | rlang \ 31 | rmarkdown \ 32 | testthat 33 | 34 | COPY . /src 35 | RUN R CMD INSTALL /src 36 | -------------------------------------------------------------------------------- /inst/js/README.md: -------------------------------------------------------------------------------- 1 | # odin JavaScript support 2 | 3 | To run models in JavaScript we use support from two JavaScript packages: 4 | 5 | * [`odin.js`](https://mrc-ide.github.io/odin-js) for continuous time (ODE) models 6 | * [`dust.js`](https://mrc-ide.github.io/dust-js) for discrete time (and usually stochastic) models 7 | 8 | Run `./scripts/update_js` to update these packages automatically to the most recent version (currently this uses the most recent version merged to main, but later we may switch to the most recent version published to npm once we settle on a workflow there). 9 | 10 | The other js code here is handwritten and only used in tests: 11 | 12 | * `dust-rng.js` provides an interface to R's random number generator (requires running via the V8 package with a host copy of R) 13 | * `test-continuous.js` and `test-discrete.js` provide wrappers for running the wodin interface from R's tests 14 | -------------------------------------------------------------------------------- /inst/WORDLIST: -------------------------------------------------------------------------------- 1 | AppVeyor 2 | CodeFactor 3 | Deserialise 4 | Dormand 5 | FitzJohn 6 | JS 7 | Jombart 8 | Kalman 9 | Lotka 10 | ODEs 11 | Poisson 12 | R's 13 | Rcpp 14 | Rmath 15 | Rtools 16 | SEIRDS 17 | Thibaut 18 | TypeScript 19 | Vano 20 | VignetteEncoding 21 | VignetteEngine 22 | VignetteIndexEntry 23 | Volterra 24 | WIP 25 | ac 26 | api 27 | autogeneration 28 | codecov 29 | compiledCode 30 | composable 31 | dC 32 | dI 33 | dN 34 | dR 35 | dS 36 | dde 37 | deSolve 38 | debuggable 39 | deserialisation 40 | dide 41 | dt 42 | epimodels 43 | etc 44 | frac 45 | gcc 46 | github 47 | ic 48 | inspectable 49 | io 50 | ir 51 | js 52 | json 53 | knitr 54 | lorenz 55 | mathcal 56 | mrc 57 | odin's 58 | pMCMC 59 | pkgbuild 60 | proc 61 | rightarrow 62 | rmarkdown 63 | roxygen 64 | rtools 65 | sim 66 | sprintf 67 | standalone 68 | struct 69 | susceptibles 70 | th 71 | toc 72 | tradeoffs 73 | uk 74 | wikipedia 75 | wodin 76 | -------------------------------------------------------------------------------- /tests/testthat/stochastic/sir_discrete_stochastic_multi.R: -------------------------------------------------------------------------------- 1 | 2 | update(S) <- S - n_SI 3 | update(I) <- I + n_SI - n_IRD 4 | update(R) <- R + n_IR 5 | update(D) <- D + n_ID 6 | 7 | initial(S) <- S0 8 | initial(I) <- 10 9 | initial(R) <- 0 10 | initial(D) <- 0 11 | 12 | p_SI <- 1 - exp(-beta * I / N) 13 | p_IRD <- 1 - exp(-gamma) 14 | 15 | n_SI <- rbinom(S, p_SI) 16 | 17 | n_IRD <- rbinom(I, p_IRD) 18 | ## NOTE: rmultinom must be the only call on the rhs, lhs must be an 19 | ## array. The p argument must be an array that is the same size as 20 | ## tmp, but this is not checked and will just happily crash if you get 21 | ## it wrong. 22 | tmp[] <- rmultinom(n_IRD, p) 23 | n_IR <- tmp[1] 24 | n_ID <- tmp[2] 25 | 26 | mu <- user(1) 27 | p[1] <- mu 28 | p[2] <- 1 - mu 29 | dim(p) <- 2 30 | dim(tmp) <- 2 31 | 32 | S0 <- user(100) 33 | beta <- user(0.1) 34 | gamma <- user(0.1) 35 | 36 | N <- S + I + R + D 37 | output(N) <- TRUE 38 | -------------------------------------------------------------------------------- /tests/testthat/helper-examples.R: -------------------------------------------------------------------------------- 1 | ## Update these as more models are added. 2 | ODIN_TO_TEST <- c("lorenz", "sir", "seir", "array", "array_2d", "seir_array") 3 | 4 | source1 <- function(filename) { 5 | x <- source(filename, local = TRUE) 6 | if (!is.function(x$value)) { 7 | stop("Did not get expected output from source") 8 | } 9 | x$value() 10 | } 11 | 12 | seq_range <- function(t, length.out) { 13 | seq(t[[1L]], t[[2L]], length.out = length.out) 14 | } 15 | 16 | ## Lagvalue with the same semantics as BM; if a positive time is used 17 | ## then we'll get the lagged value. Otherwise take the value from the 18 | ## initial conditions (y0). 19 | make_lagvalue <- function(t0, y0) { 20 | force(t0) 21 | y0 <- unname(y0) 22 | function(t, lag, nr = 0L) { 23 | t1 <- t - lag 24 | if (t1 > t0) { 25 | deSolve::lagvalue(t1, nr) 26 | } else if (length(nr) == 1 && nr == 0L) { 27 | y0 28 | } else { 29 | y0[nr] 30 | } 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /man/odin_ir_deserialise.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ir_deserialise.R 3 | \name{odin_ir_deserialise} 4 | \alias{odin_ir_deserialise} 5 | \title{Deserialise odin's IR} 6 | \usage{ 7 | odin_ir_deserialise(x) 8 | } 9 | \arguments{ 10 | \item{x}{An intermediate representation as a json string} 11 | } 12 | \value{ 13 | A named list 14 | } 15 | \description{ 16 | Deserialise odin's intermediate model representation from a json 17 | string into an R object. Unlike the json, there is no schema for 18 | this representation. This function provides access to the same 19 | deserialisation that odin uses internally so may be useful in 20 | applications. 21 | } 22 | \examples{ 23 | # Parse a model of exponential decay 24 | ir <- odin::odin_parse({ 25 | deriv(y) <- -0.5 * y 26 | initial(y) <- 1 27 | }) 28 | # Convert the representation to an R object 29 | odin::odin_ir_deserialise(ir) 30 | } 31 | \seealso{ 32 | \link{odin_parse} 33 | } 34 | -------------------------------------------------------------------------------- /tests/testthat/test-run-regression.R: -------------------------------------------------------------------------------- 1 | context("run: regression") 2 | 3 | test_that_odin("bug #78", { 4 | gen <- odin({ 5 | n <- 2 6 | m <- 2 7 | deriv(S[, ]) <- 0 8 | deriv(I) <- S[n, m] 9 | dim(S) <- c(n, m) 10 | initial(S[, ]) <- S0[i, j] 11 | initial(I) <- 0 12 | S0[, ] <- user() 13 | dim(S0) <- c(n, m) 14 | }) 15 | 16 | parameters <- list(S0 = cbind(c(1, 2), c(3, 4))) 17 | mod <- gen$new(user = parameters) 18 | expect_equal(mod$deriv(0, mod$initial(0)), 19 | c(4, rep(0, 4))) 20 | }) 21 | 22 | 23 | ## 75 24 | test_that_odin("bug #75", { 25 | gen <- odin({ 26 | deriv(S) <- 1 27 | deriv(I) <- 2 28 | deriv(R) <- 3 29 | 30 | initial(S) <- N - I - R 31 | initial(I) <- I0 32 | initial(R) <- 5 33 | 34 | N <- 100 35 | I0 <- 1 36 | }) 37 | 38 | dat <- gen$new()$contents() 39 | expect_equal(dat$initial_S, 94) 40 | expect_equal(dat$initial_I, 1) 41 | expect_equal(dat$initial_R, 5) 42 | }) 43 | -------------------------------------------------------------------------------- /man/odin_ir.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{odin_ir} 4 | \alias{odin_ir} 5 | \title{Return detailed information about an odin model} 6 | \usage{ 7 | odin_ir(x, parsed = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{An \code{odin_generator} function, as created by 11 | \code{odin::odin}} 12 | 13 | \item{parsed}{Logical, indicating if the representation should be 14 | parsed and converted into an R object. If \code{FALSE} we 15 | return a json string.} 16 | } 17 | \description{ 18 | Return detailed information about an odin model. This is the 19 | mechanism through which \link{coef} works with odin. 20 | } 21 | \section{Warning}{ 22 | 23 | 24 | The returned data is subject to change for a few versions while I 25 | work out how we'll use it. 26 | } 27 | 28 | \examples{ 29 | exp_decay <- odin::odin({ 30 | deriv(y) <- -0.5 * y 31 | initial(y) <- 1 32 | }, target = "r") 33 | odin::odin_ir(exp_decay) 34 | coef(exp_decay) 35 | } 36 | -------------------------------------------------------------------------------- /tests/testthat/helper-differentiate.R: -------------------------------------------------------------------------------- 1 | ## Continuous distributions are easy: 2 | expectation_continuous <- function(fd, pars, from, to) { 3 | integrate( 4 | function(x) x * do.call(fd, c(list(x), unname(pars))), 5 | from, to)$value 6 | } 7 | 8 | 9 | ## Discrete distrbutions are somewhat harder. Take fd (the density 'd' 10 | ## function, e.g. dbinom) and fq (the corresponding quantile 'q' 11 | ## function, e.g., qbinom) and work out some suitably far out value 12 | ## that we capture at least 1-tol of the probability mass, then sum 13 | ## over that. This is not quite an infinite sum but at tolerance of 14 | ## 1e-12 we're around the limits of what we'd get summing over many 15 | ## floating point numbers (and this is only used in tests with a 16 | ## looser tolerance anyway) 17 | expectation_discrete <- function(fd, fq, pars, tol = 1e-12) { 18 | end <- do.call(fq, c(list(p = 1 - tol), unname(pars))) 19 | n <- seq(0, end, by = 1) 20 | sum(n * do.call(fd, c(list(n), unname(pars)))) 21 | } 22 | -------------------------------------------------------------------------------- /inst/examples/discrete_stochastic_sir_arrays.R: -------------------------------------------------------------------------------- 1 | ## Core equations for transitions between compartments: 2 | update(S[]) <- S[i] - n_SI[i] 3 | update(I[]) <- I[i] + n_SI[i] - n_IR[i] 4 | update(R[]) <- R[i] + n_IR[i] 5 | 6 | ## Individual probabilities of transition: 7 | p_SI[] <- 1 - exp(-beta * I[i] / N[i]) 8 | p_IR <- 1 - exp(-gamma) 9 | 10 | ## Draws from binomial distributions for numbers changing between 11 | ## compartments: 12 | n_SI[] <- rbinom(S[i], p_SI[i]) 13 | n_IR[] <- rbinom(I[i], p_IR) 14 | 15 | ## Total population size 16 | N[] <- S[i] + I[i] + R[i] 17 | 18 | ## Initial states: 19 | initial(S[]) <- S_ini 20 | initial(I[]) <- I_ini 21 | initial(R[]) <- 0 22 | 23 | ## User defined parameters - default in parentheses: 24 | S_ini <- user(1000) 25 | I_ini <- user(1) 26 | beta <- user(0.2) 27 | gamma <- user(0.1) 28 | 29 | ## Number of replicates 30 | nsim <- user(100) 31 | dim(N) <- nsim 32 | dim(S) <- nsim 33 | dim(I) <- nsim 34 | dim(R) <- nsim 35 | dim(p_SI) <- nsim 36 | dim(n_SI) <- nsim 37 | dim(n_IR) <- nsim 38 | -------------------------------------------------------------------------------- /inst/LICENSE.random: -------------------------------------------------------------------------------- 1 | Copyright 2021 Travis Fischer 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /tests/testthat/test-can-compile.R: -------------------------------------------------------------------------------- 1 | context("can compile") 2 | 3 | test_that("can_compile", { 4 | skip_on_cran() 5 | expect_true(can_compile()) 6 | expect_true(can_compile()) 7 | expect_true(can_compile(refresh = TRUE)) 8 | }) 9 | 10 | 11 | test_that("target", { 12 | skip_on_cran() 13 | oo <- options(odin.target = NULL) 14 | on.exit({ 15 | .odin$can_compile <- NULL 16 | options(oo) 17 | }) 18 | 19 | .odin$can_compile <- NULL 20 | expect_equal(odin_options(target = NULL)$target, "c") 21 | expect_equal(odin_options(target = "c")$target, "c") 22 | expect_equal(odin_options(target = "r")$target, "r") 23 | 24 | .odin$can_compile <- FALSE 25 | expect_equal(odin_options(target = NULL)$target, "r") 26 | expect_equal(odin_options(target = "r")$target, "r") 27 | expect_equal(odin_options(target = "c")$target, "c") 28 | 29 | .odin$can_compile <- TRUE 30 | expect_equal(odin_options(target = NULL)$target, "c") 31 | expect_equal(odin_options(target = "r")$target, "r") 32 | expect_equal(odin_options(target = "c")$target, "c") 33 | }) 34 | -------------------------------------------------------------------------------- /tests/testthat/random.js: -------------------------------------------------------------------------------- 1 | // A little helper to generate random numbers from the dust rng from 2 | // any distribution; we need this to make the tests easy! 3 | // 4 | // Note that this reuses inst/js/dust-rng.js for calling back to R so 5 | // that the random number generation respects set.seed (this is all a 6 | // bit nasty, and we'll probably sort this out more elegantly in 7 | // dust.js later, but there's some fairly unresolvable issues with 8 | // seedable random number streams in js to deal with first). 9 | // 10 | // We do the serialisation to JSON string here rather than relying on 11 | // V8 as this preserves full precision. 12 | function random(distribution, n, args) { 13 | const rng = { 14 | random: function() { 15 | return JSON.parse(console.r.call("function() jsonlite::toJSON(runif(1), digits = NA, auto_unbox = TRUE)", [])); 16 | } 17 | }; 18 | let r = new dust.PkgWrapper.random(rng); 19 | const ret = []; 20 | for (let i = 0; i < n; ++i) { 21 | ret.push(r[distribution](...args)); 22 | } 23 | return JSON.stringify(ret); 24 | } 25 | -------------------------------------------------------------------------------- /scripts/update_js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -exu 3 | 4 | ODIN_JS_BRANCH=main 5 | DUST_JS_BRANCH=main 6 | 7 | HERE=$(dirname $0) 8 | PACKAGE_ROOT=$(realpath $HERE/..) 9 | 10 | PATH_BUILD=$PACKAGE_ROOT/build 11 | PATH_DUST=$PATH_BUILD/dust-js 12 | PATH_ODIN=$PATH_BUILD/odin-js 13 | 14 | update_source() { 15 | SRC=$1 16 | DEST=$2 17 | REF=$3 18 | if [[ -d "$DEST" ]]; then 19 | git -C "$DEST" fetch 20 | else 21 | mkdir -p $PATH_BUILD 22 | git clone "$SRC" "$DEST" 23 | fi 24 | git -C "$DEST" checkout "origin/$REF" 25 | } 26 | 27 | build_js() { 28 | SRC=$1 29 | FILE=$2 30 | DEST="$PACKAGE_ROOT/inst/js/$FILE" 31 | npm --prefix $SRC ci 32 | npm --prefix $SRC run webpack 33 | cp $SRC/dist/$FILE $DEST 34 | ## Webpack builds files with no newlines, let's add one here 35 | echo "" >> $PACKAGE_ROOT/inst/js/$FILE 36 | } 37 | 38 | update_source https://github.com/mrc-ide/dust-js $PATH_DUST $DUST_JS_BRANCH 39 | build_js $PATH_DUST dust.js 40 | 41 | update_source https://github.com/mrc-ide/odin-js $PATH_ODIN $ODIN_JS_BRANCH 42 | build_js $PATH_ODIN odin.js 43 | -------------------------------------------------------------------------------- /R/compat.R: -------------------------------------------------------------------------------- 1 | ## This file exists to support the workaround to fix issue #206. Once 2 | ## the deprecation period is over, it can be removed, and the 3 | ## generated code changed slightly. 4 | 5 | ##' @export 6 | `[[.odin_generator` <- function(x, i) { 7 | attr(x, "generator", exact = TRUE)[[i]] 8 | } 9 | 10 | 11 | ##' @export 12 | `$.odin_generator` <- function(x, name) { 13 | attr(x, "generator", exact = TRUE)[[name]] 14 | } 15 | 16 | 17 | ##' @importFrom utils .DollarNames 18 | ##' @export 19 | .DollarNames.odin_generator <- function(x, pattern) { 20 | .DollarNames(attr(x, "generator", exact = TRUE)) 21 | } 22 | 23 | ##' @export 24 | print.odin_generator <- function(x, ...) { 25 | print(attr(x, "generator", exact = TRUE)) 26 | } 27 | 28 | deprecated_constructor_call <- function(name) { 29 | calls <- sys.calls() 30 | n <- length(calls) - 1L # second to last call would be us 31 | if (n >= 1 && is.symbol(calls[[n]][[1]])) { 32 | nm <- as.character(calls[[n]][[1]]) 33 | } else { 34 | nm <- name 35 | } 36 | warning(sprintf( 37 | "'%s(...)' is deprecated; please use '%s$new(...)' instead", nm, nm), 38 | call. = FALSE) 39 | } 40 | -------------------------------------------------------------------------------- /inst/LICENSE.dopri: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Imperial College of Science, Technology and Medicine 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 11 | all 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 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /R/ir_substitute.R: -------------------------------------------------------------------------------- 1 | ## ir_substitute and callees is used to rewrite expressions that use 2 | ## arrays within delay blocks 3 | ir_substitute <- function(eqs, substitutions) { 4 | if (length(substitutions) == 0L) { 5 | return(eqs) 6 | } 7 | 8 | lapply(eqs, ir_substitute1, substitutions) 9 | } 10 | 11 | 12 | ir_substitute1 <- function(eq, substitutions) { 13 | from <- names(substitutions) 14 | if (any(from %in% eq$depends$variables)) { 15 | if (eq$type == "expression_array") { 16 | f <- function(x) { 17 | x$value <- ir_substitute_sexpr(x$value, substitutions) 18 | x 19 | } 20 | eq$rhs <- lapply(eq$rhs, f) 21 | } else { 22 | eq$rhs$value <- ir_substitute_sexpr(eq$rhs$value, substitutions) 23 | } 24 | } 25 | if (eq$lhs %in% from) { 26 | eq$lhs <- substitutions[[eq$lhs]] 27 | } 28 | eq 29 | } 30 | 31 | 32 | ir_substitute_sexpr <- function(expr, substitutions) { 33 | if (length(substitutions) == 0L) { 34 | expr 35 | } else if (is.recursive(expr)) { 36 | lapply(expr, ir_substitute_sexpr, substitutions) 37 | } else if (is.character(expr) && expr %in% names(substitutions)) { 38 | substitutions[[expr]] 39 | } else { 40 | expr 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /man/odin_js_bundle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/js_bundle.R 3 | \name{odin_js_bundle} 4 | \alias{odin_js_bundle} 5 | \title{Create a bundle of an odin model} 6 | \usage{ 7 | odin_js_bundle(code, include_support = TRUE) 8 | } 9 | \arguments{ 10 | \item{code}{An expression, string or path to a file containing 11 | odin code (as for \link{odin_parse_}). If \code{NULL}, compile no 12 | model and return only the support code.} 13 | 14 | \item{include_support}{Logical, indicating if the support code 15 | should be included. Without this you need to manually copy over 16 | odin.js or dust.js depending on what model type you have.} 17 | } 18 | \value{ 19 | A list, with contents subject to change. 20 | } 21 | \description{ 22 | Create a JavaScript bundle of an odin model 23 | } 24 | \section{Warning}{ 25 | 26 | 27 | The interface and generated code here are subject to change. As it 28 | stands, it does what is needed for our work in 29 | \href{https://github.com/mrc-ide/odin.api}{odin.api} and does not 30 | actually produce a useful bundle! 31 | } 32 | 33 | \examples{ 34 | js <- odin::odin_js_bundle(quote({ 35 | deriv(x) <- 1 36 | initial(x) <- 1 37 | }), include_support = FALSE) 38 | head(js$model$code, 20) 39 | } 40 | -------------------------------------------------------------------------------- /man/can_compile.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/can_compile.R 3 | \name{can_compile} 4 | \alias{can_compile} 5 | \title{Test if compilation is possible} 6 | \usage{ 7 | can_compile(verbose = FALSE, refresh = FALSE) 8 | } 9 | \arguments{ 10 | \item{verbose}{Be verbose when running commands?} 11 | 12 | \item{refresh}{Try again to compile, skipping the cached value?} 13 | } 14 | \value{ 15 | A logical scalar 16 | } 17 | \description{ 18 | Test if compilation appears possible. This is used in some 19 | examples, and tries compiling a trivial C program with 20 | \code{pkgbuild}. Results are cached between runs within a session 21 | so this should be fast to rely on. 22 | } 23 | \details{ 24 | We use \code{pkgbuild} in order to build packages, and it includes a 25 | set of heuristics to locate and organise your C compiler. The most 26 | likely people affected here are Windows users; if you get this 27 | ensure that you have rtools installed. Using 28 | \code{\link[pkgbuild:has_rtools]{pkgbuild::find_rtools()}} with \code{debug = TRUE} may be helpful for 29 | diagnosing compiler issues. 30 | } 31 | \examples{ 32 | can_compile() # will take ~0.1s the first time 33 | can_compile() # should be basically instantaneous 34 | } 35 | -------------------------------------------------------------------------------- /R/can_compile.R: -------------------------------------------------------------------------------- 1 | ##' Test if compilation appears possible. This is used in some 2 | ##' examples, and tries compiling a trivial C program with 3 | ##' `pkgbuild`. Results are cached between runs within a session 4 | ##' so this should be fast to rely on. 5 | ##' 6 | ##' We use `pkgbuild` in order to build packages, and it includes a 7 | ##' set of heuristics to locate and organise your C compiler. The most 8 | ##' likely people affected here are Windows users; if you get this 9 | ##' ensure that you have rtools installed. Using 10 | ##' [pkgbuild::find_rtools()] with `debug = TRUE` may be helpful for 11 | ##' diagnosing compiler issues. 12 | ##' 13 | ##' @title Test if compilation is possible 14 | ##' 15 | ##' @param verbose Be verbose when running commands? 16 | ##' 17 | ##' @param refresh Try again to compile, skipping the cached value? 18 | ##' 19 | ##' @return A logical scalar 20 | ##' 21 | ##' @export 22 | ##' @examples 23 | ##' can_compile() # will take ~0.1s the first time 24 | ##' can_compile() # should be basically instantaneous 25 | can_compile <- function(verbose = FALSE, refresh = FALSE) { 26 | if (refresh || is.null(.odin$can_compile)) { 27 | .odin$can_compile <- 28 | requireNamespace("pkgbuild", quietly = verbose) && 29 | pkgbuild::check_build_tools(verbose, !verbose) 30 | } 31 | .odin$can_compile %||% FALSE 32 | } 33 | -------------------------------------------------------------------------------- /R/ir_parse_error.R: -------------------------------------------------------------------------------- 1 | ## We're going to need to wrap this up like testthat I think, so that 2 | ## we can catch these and group them together. But leaving that for 3 | ## now. 4 | ir_parse_error <- function(msg, line, source) { 5 | ret <- ir_parse_error_data(msg, unique(line), source, "error") 6 | class(ret) <- c("odin_error", "error", "condition") 7 | stop(ret) 8 | } 9 | 10 | 11 | ir_parse_note <- function(msg, line, source) { 12 | announce <- .odin$note_function %||% function(x) message(x$message) 13 | ret <- ir_parse_error_data(msg, unique(line), source, "message") 14 | announce(ret) 15 | } 16 | 17 | 18 | ir_parse_error_data <- function(msg, line, source, type) { 19 | if (length(line) > 0L) { 20 | expr <- source[line] 21 | str <- sprintf("%s # (line %s)", expr, line) 22 | message <- paste0(msg, paste0("\n\t", str, collapse = "")) 23 | } else { 24 | ## There are not many cases that will trigger this - the most used 25 | ## one is where we have no equations at all. The other (more 26 | ## used) case is in testing. 27 | expr <- NULL 28 | message <- msg 29 | } 30 | list(message = message, 31 | msg = msg, 32 | line = line, 33 | expr = expr, 34 | type = type) 35 | } 36 | 37 | 38 | ir_parse_error_lines <- function(eqs) { 39 | unlist(unname(lapply(eqs, "[[", "source"))) 40 | } 41 | -------------------------------------------------------------------------------- /tests/testthat/test-ring-cache.R: -------------------------------------------------------------------------------- 1 | context("model cache") 2 | 3 | test_that("model_cache", { 4 | obj <- R6_ring_cache$new(10) 5 | 6 | expect_equal(obj$list(), character()) 7 | expect_null(obj$get("a")) 8 | x <- runif(10) 9 | obj$put("a", x) 10 | expect_equal(obj$list(), "a") 11 | expect_equal(obj$get("a"), x) 12 | 13 | ## overflow the ring 14 | obj$resize(4) 15 | for (x in letters[2:4]) { 16 | obj$put(x, x) 17 | } 18 | expect_equal(obj$list(), c("d", "c", "b", "a")) 19 | 20 | obj$put("e", "e") 21 | expect_equal(obj$list(), c("e", "d", "c", "b")) 22 | 23 | obj$put("c", "c") 24 | expect_equal(obj$list(), c("c", "e", "d", "b")) 25 | 26 | obj$get("d") 27 | expect_equal(obj$list(), c("d", "c", "e", "b")) 28 | 29 | obj$resize(2) 30 | expect_equal(obj$list(), c("d", "c")) 31 | 32 | obj$clear() 33 | expect_equal(obj$list(), character()) 34 | }) 35 | 36 | 37 | test_that("reused cached model", { 38 | skip_on_cran() 39 | model_cache_clear() 40 | code <- c("deriv(y) <- 0.5", 41 | "initial(y) <- 1") 42 | 43 | gen <- odin(code, target = "c") 44 | expect_equal(.odin$model_cache_c$list(), 45 | hash_string(gen$new()$ir())) 46 | expect_message(odin(code, target = "c", verbose = TRUE), 47 | "Using cached model") 48 | expect_silent(odin(code, target = "c", verbose = FALSE)) 49 | }) 50 | 51 | 52 | unload_dlls() 53 | -------------------------------------------------------------------------------- /tests/testthat/examples/seir_deSolve.R: -------------------------------------------------------------------------------- 1 | seir <- function() { 2 | b <- 1 / 10 3 | N <- 1e7 4 | beta <- 10 5 | sigma <- 1 / 3 6 | delta <- 1 / 21 7 | lat_hum <- 14 8 | I0 <- 1 9 | 10 | Births <- N * b 11 | ## i.e. proportion of humans surviving the latent period 12 | surv <- exp(-b * lat_hum) 13 | 14 | t0 <- NULL 15 | y0 <- NULL 16 | lag <- NULL 17 | 18 | initial <- function(t = 0, pars = NULL) { 19 | if ("I0" %in% names(pars)) { 20 | I0 <<- pars$I0 21 | } 22 | t0 <<- t 23 | y0 <<- c(S = N - I0, E = 0, I = I0, R = 0) 24 | lag <<- make_lagvalue(t0, y0) 25 | y0 26 | } 27 | 28 | derivs <- function(t, y, .) { 29 | S <- y[[1L]] 30 | E <- y[[2L]] 31 | I <- y[[3L]] 32 | R <- y[[4L]] 33 | 34 | ## people developing latent infection 35 | new_inf <- beta * S * I / N 36 | 37 | ## people that become latent 'lat_hum' days ago, less those that 38 | ## died during that time 39 | S_lag <- lag(t, lat_hum, 1L) 40 | I_lag <- lag(t, lat_hum, 3L) 41 | lag_inf <- S_lag * I_lag * beta * surv / N 42 | 43 | dS <- Births - b * S - new_inf + delta * R 44 | dE <- new_inf - lag_inf - b * E 45 | dI <- lag_inf - (b + sigma) * I 46 | dR <- sigma * I - b * R - delta * R 47 | 48 | list(c(dS, dE, dI, dR)) 49 | ## Output variables 50 | ## c(prev = I/N, Hpop = S+E+I+R)) 51 | } 52 | 53 | list(initial = initial, derivs = derivs, delay = TRUE, t = c(0, 365)) 54 | } 55 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.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 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | runs-on: ubuntu-latest 17 | # Only restrict concurrency for non-PR jobs 18 | concurrency: 19 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 20 | env: 21 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 22 | steps: 23 | - uses: actions/checkout@v3 24 | 25 | - uses: r-lib/actions/setup-pandoc@v2 26 | 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | 31 | - uses: r-lib/actions/setup-r-dependencies@v2 32 | with: 33 | extra-packages: any::pkgdown, local::. 34 | needs: website 35 | 36 | - name: Build site 37 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 38 | shell: Rscript {0} 39 | 40 | - name: Deploy to GitHub pages 🚀 41 | if: github.event_name != 'pull_request' 42 | uses: JamesIves/github-pages-deploy-action@v4.4.1 43 | with: 44 | clean: false 45 | branch: gh-pages 46 | folder: docs 47 | -------------------------------------------------------------------------------- /tests/testthat/examples/array_bm.txt: -------------------------------------------------------------------------------- 1 | ; From Hannah Slater, 2016-02-09 2 | METHOD RK4 3 | 4 | STARTTIME = 0 5 | STOPTIME=100 6 | DT = 0.01 7 | 8 | N_age = 5 9 | ; mean no. of days in each age compartment (0 - 1 yr, 1 - 5 yr, 5 - 15 yr, 15 - 30yr, 30 +) 10 | age_width[1] = 365*1 11 | age_width[2] = 365*4 12 | age_width[3] = 365*10 13 | age_width[4] = 365*15 14 | age_width[5] = 365*20 15 | 16 | age_rate[1..N_age-1] = 1/age_width[i] 17 | age_rate[N_age] = 0 18 | 19 | den[1]=1/(1+age_rate[1]/b) 20 | den[2..N_age]=age_rate[i-1]*den[i-1]/(age_rate[i]+b) ; to work out the % of the population in each age group 21 | 22 | den_tot = arraysum(den[*]) ; test to make sure densities add up to 1 23 | 24 | 25 | init S[1..N_age] = den[i]*(N-1) 26 | init I[1..N_age] =den[i]*1 27 | init R[1..N_age] = den[i]*0 28 | 29 | 30 | Births = b*N 31 | b = 1/(365*50) 32 | N = 1e7 33 | beta = 1 34 | sigma = 1/30 35 | delta = 1/60 36 | 37 | I_tot = arraysum(I[*]) 38 | 39 | d/dt( S[1..N_age] ) = - beta*S[i]*I_tot/N + delta*R[i] - b*S[i] + (if i = 1 then Births - age_rate[i]*S[i] else age_rate[i-1]*S[i-1] - age_rate[i]*S[i]) 40 | d/dt( I[1..N_age] ) = beta*S[i]*I_tot/N - (b+sigma)*I[i] + (if i = 1 then - age_rate[i]*I[i] else age_rate[i-1]*I[i-1] - age_rate[i]*I[i]) 41 | 42 | d/dt( R[1..N_age] ) = sigma*I[i] - b*R[i]-delta*R[i] + (if i = 1 then - age_rate[i]*R[i] else age_rate[i-1]*R[i-1] - age_rate[i]*R[i]) 43 | 44 | N_tot =arraysum(S[*])+arraysum(I[*])+arraysum(R[*]) 45 | 46 | prev = I_tot / N_tot*100 47 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /R/generate_r_utils.R: -------------------------------------------------------------------------------- 1 | r_offset_to_position <- function(x) { 2 | if (is.language(x)) { 3 | call("+", x, 1L) 4 | } else { 5 | x + 1L 6 | } 7 | } 8 | 9 | 10 | r_fold_call <- function(fn, args) { 11 | ret <- args[[1L]] 12 | for (i in seq_along(args)[-1L]) { 13 | ret <- call(fn, ret, args[[i]]) 14 | } 15 | ret 16 | } 17 | 18 | 19 | r_flatten_eqs <- function(x) { 20 | x <- unname(x) 21 | if (any(vlapply(x, is.list))) { 22 | x <- unlist(x, FALSE, FALSE) 23 | } 24 | x 25 | } 26 | 27 | 28 | r_unpack_variable <- function(x, data, state, rewrite) { 29 | call("<-", as.name(x$name), r_extract_variable(x, data, state, rewrite)) 30 | } 31 | 32 | 33 | r_extract_variable <- function(x, data, state, rewrite) { 34 | d <- data[[x$name]] 35 | if (d$rank == 0L) { 36 | extract <- call("[[", state, r_offset_to_position(x$offset)) 37 | } else { 38 | seq <- call("seq_len", rewrite(d$dimnames$length)) 39 | extract <- call("[", state, call("+", rewrite(x$offset), seq)) 40 | if (d$rank > 1L) { 41 | extract <- call("array", extract, generate_r_dim(d, rewrite)) 42 | } 43 | } 44 | extract 45 | } 46 | 47 | 48 | r_expr_block <- function(exprs) { 49 | if (is.language(exprs)) { 50 | exprs <- list(exprs) 51 | } else { 52 | exprs <- r_flatten_eqs(exprs) 53 | } 54 | as.call(c(list(as.name("{")), exprs)) 55 | } 56 | 57 | 58 | r_expr_if <- function(condition, a, b) { 59 | call("if", condition, r_expr_block(a), r_expr_block(b)) 60 | } 61 | 62 | 63 | r_expr_local <- function(exprs) { 64 | call("local", r_expr_block(exprs)) 65 | } 66 | -------------------------------------------------------------------------------- /tests/testthat/test-js-wrapper.R: -------------------------------------------------------------------------------- 1 | context("wrapper") 2 | 3 | 4 | test_that("force a vector of strings", { 5 | skip_if_no_js() 6 | gen <- odin(c("deriv(y) <- 0.5", "initial(y) <- 1"), 7 | target = "js") 8 | expect_equal(gen$public_methods$engine(), "js") 9 | mod <- gen$new() 10 | y <- mod$run(0:10)[, "y"] 11 | expect_equal(y, seq(1, by = 0.5, length.out = 11)) 12 | }) 13 | 14 | 15 | test_that("force a symbol of code", { 16 | skip_if_no_js() 17 | code <- quote({ 18 | deriv(y) <- 0.5 19 | initial(y) <- 1 20 | }) 21 | gen <- odin(code, target = "js") 22 | mod <- gen$new() 23 | y <- mod$run(0:10)[, "y"] 24 | expect_equal(y, seq(1, by = 0.5, length.out = 11)) 25 | }) 26 | 27 | 28 | test_that("allow initial conditions", { 29 | skip_if_no_js() 30 | code <- quote({ 31 | deriv(y) <- 0.5 32 | initial(y) <- 1 33 | }) 34 | gen <- odin(code, target = "js") 35 | mod <- gen$new() 36 | y <- mod$run(0:10, 2)[, "y"] 37 | expect_equal(y, seq(2, by = 0.5, length.out = 11)) 38 | }) 39 | 40 | 41 | test_that("return statistics", { 42 | skip_if_no_js() 43 | code <- quote({ 44 | deriv(y) <- sin(y) 45 | initial(y) <- 1 46 | }) 47 | gen <- odin(code, target = "js") 48 | mod <- gen$new() 49 | 50 | expect_null(attr(mod$run(0:10), "statistics")) 51 | res <- mod$run(0:10, return_statistics = TRUE) 52 | statistics <- attr(res, "statistics") 53 | expect_is(statistics, "integer") 54 | expect_equal(names(statistics), 55 | c("n_eval", "n_step", "n_accept", "n_reject")) 56 | expect_true(all(statistics) >= 0) 57 | }) 58 | -------------------------------------------------------------------------------- /R/js_bundle.R: -------------------------------------------------------------------------------- 1 | ##' Create a JavaScript bundle of an odin model 2 | ##' 3 | ##' @section Warning: 4 | ##' 5 | ##' The interface and generated code here are subject to change. As it 6 | ##' stands, it does what is needed for our work in 7 | ##' [odin.api](https://github.com/mrc-ide/odin.api) and does not 8 | ##' actually produce a useful bundle! 9 | ##' 10 | ##' @title Create a bundle of an odin model 11 | ##' 12 | ##' @param code An expression, string or path to a file containing 13 | ##' odin code (as for [odin::odin_parse_]). If `NULL`, compile no 14 | ##' model and return only the support code. 15 | ##' 16 | ##' @param include_support Logical, indicating if the support code 17 | ##' should be included. Without this you need to manually copy over 18 | ##' odin.js or dust.js depending on what model type you have. 19 | ##' 20 | ##' @return A list, with contents subject to change. 21 | ##' 22 | ##' @export 23 | ##' @examples 24 | ##' js <- odin::odin_js_bundle(quote({ 25 | ##' deriv(x) <- 1 26 | ##' initial(x) <- 1 27 | ##' }), include_support = FALSE) 28 | ##' head(js$model$code, 20) 29 | odin_js_bundle <- function(code, include_support = TRUE) { 30 | ret <- list() 31 | 32 | options <- odin_options(target = "js") 33 | ir <- odin_parse_(code, options) 34 | dat <- generate_js(ir, options) 35 | ret$model <- list(code = dat$code, name = dat$name) 36 | ret$is_discrete <- dat$features$discrete 37 | ret$support_file <- if (ret$is_discrete) "dust.js" else "odin.js" 38 | 39 | if (include_support) { 40 | ret$support <- readLines(odin_file(file.path("js", ret$support_file))) 41 | } 42 | 43 | ret 44 | } 45 | -------------------------------------------------------------------------------- /tests/testthat/test-odin-validate.R: -------------------------------------------------------------------------------- 1 | context("odin_validate") 2 | 3 | 4 | test_that("valid model", { 5 | code <- c("initial(x) <- 1", "deriv(x) <- 1") 6 | res <- odin_validate(code, "text") 7 | expect_true(res$success) 8 | expect_null(res$error) 9 | expect_is(res$result, "json") 10 | expect_equal(res$messages, list()) 11 | }) 12 | 13 | 14 | test_that("invalid model", { 15 | code <- c("initial(x) <- 1", "deriv(x)") 16 | res <- odin_validate(code, "text") 17 | expect_false(res$success) 18 | expect_null(res$result) 19 | expect_is(res$error, "odin_error") 20 | expect_equal(res$messages, list()) 21 | }) 22 | 23 | 24 | test_that("unused variables can be detected", { 25 | code <- c("initial(x) <- 1", "deriv(x) <- 1", "a <- 1") 26 | res <- odin_validate(code, "text", 27 | odin_options(rewrite_constants = FALSE)) 28 | expect_equal(length(res$messages), 1L) 29 | expect_match(res$messages[[1]]$msg, "Unused equation: a") 30 | expect_equivalent(res$messages[[1]]$line, 3) 31 | }) 32 | 33 | 34 | test_that("invalid R", { 35 | code <- "a b" 36 | res <- odin_validate(code, "text") 37 | expect_false(res$success) 38 | expect_null(res$result) 39 | expect_is(res$error, "error") 40 | expect_equal(res$messages, list()) 41 | }) 42 | 43 | 44 | test_that("type is passed along", { 45 | expect_equal(odin_validate("", "text")$error$message, 46 | "Did not find a deriv() or an update() call", 47 | fixed = TRUE) 48 | expect_equal(odin_validate(character(0), "text")$error$message, 49 | "Did not find a deriv() or an update() call", 50 | fixed = TRUE) 51 | }) 52 | -------------------------------------------------------------------------------- /.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 | # Shorter timeout to prevent mac builders hanging for 6 hours! 28 | timeout-minutes: 30 29 | 30 | env: 31 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 32 | R_KEEP_PKG_SOURCE: yes 33 | 34 | steps: 35 | - uses: actions/checkout@v3 36 | 37 | - uses: r-lib/actions/setup-pandoc@v2 38 | 39 | - uses: r-lib/actions/setup-r@v2 40 | with: 41 | r-version: ${{ matrix.config.r }} 42 | http-user-agent: ${{ matrix.config.http-user-agent }} 43 | use-public-rspm: true 44 | 45 | - uses: r-lib/actions/setup-r-dependencies@v2 46 | with: 47 | extra-packages: any::rcmdcheck 48 | needs: check 49 | 50 | - uses: r-lib/actions/check-r-package@v2 51 | with: 52 | upload-snapshots: true 53 | -------------------------------------------------------------------------------- /inst/examples/discrete_stochastic_seirds.R: -------------------------------------------------------------------------------- 1 | ## Core equations for transitions between compartments: 2 | update(S) <- S - n_SE + n_RS 3 | update(E) <- E + n_SE - n_EI + n_import_E 4 | update(Ir) <- Ir + n_EIr - n_IrR 5 | update(Id) <- Id + n_EId - n_IdD 6 | update(R) <- R + n_IrR - n_RS 7 | update(D) <- D + n_IdD 8 | 9 | ## Individual probabilities of transition: 10 | p_SE <- 1 - exp(-beta * I / N) 11 | p_EI <- 1 - exp(-delta) 12 | p_IrR <- 1 - exp(-gamma_R) # Ir to R 13 | p_IdD <- 1 - exp(-gamma_D) # Id to d 14 | p_RS <- 1 - exp(-omega) # R to S 15 | 16 | 17 | ## Draws from binomial distributions for numbers changing between 18 | ## compartments: 19 | n_SE <- rbinom(S, p_SE) 20 | n_EI <- rbinom(E, p_EI) 21 | 22 | n_EIrId[] <- rmultinom(n_EI, p) 23 | p[1] <- 1 - mu 24 | p[2] <- mu 25 | dim(p) <- 2 26 | dim(n_EIrId) <- 2 27 | n_EIr <- n_EIrId[1] 28 | n_EId <- n_EIrId[2] 29 | n_IrR <- rbinom(Ir, p_IrR) 30 | n_IdD <- rbinom(Id, p_IdD) 31 | 32 | n_RS <- rbinom(R, p_RS) 33 | 34 | n_import_E <- rpois(epsilon) 35 | 36 | ## Total population size, and number of infecteds 37 | I <- Ir + Id 38 | N <- S + E + I + R + D 39 | 40 | ## Initial states 41 | initial(S) <- S_ini 42 | initial(E) <- E_ini 43 | initial(Id) <- 0 44 | initial(Ir) <- 0 45 | initial(R) <- 0 46 | initial(D) <- 0 47 | 48 | ## User defined parameters - default in parentheses: 49 | S_ini <- user(1000) # susceptibles 50 | E_ini <- user(1) # infected 51 | beta <- user(0.3) # infection rate 52 | delta <- user(0.3) # inverse incubation 53 | gamma_R <- user(0.08) # recovery rate 54 | gamma_D <- user(0.12) # death rate 55 | mu <- user(0.7) # CFR 56 | omega <- user(0.01) # rate of waning immunity 57 | epsilon <- user(0.1) # import case rate 58 | -------------------------------------------------------------------------------- /development.md: -------------------------------------------------------------------------------- 1 | _This might become a vignette at some point_ 2 | 3 | There are relatively few user-facing functions in this package but rather a lot going on behind the scenes. 4 | 5 | ## Parse phase 6 | 7 | The function `odin_parse` (and `odin_parse_`) convert a model from R's syntax into an intermediate representation that includes all the information to compile the model to another language. The actual parse phase is carried out with a large number of functions that have the prefix `ir_parse`, in files prefixed by `ir_parse`. Over time these will be better organised and I'll document what happens in each phase. 8 | 9 | ## IR serialisation 10 | 11 | Even when not persisted we serialise the IR all the way to `json` using [`jsonlite`](https://cran.r-project.org/package=jsonlite); this happens in `ir_serialise.R`. All functions are prefixed with `ir_serialise` 12 | 13 | ## IR validation 14 | 15 | If requested, then the intermediate representation is validated against the schema (written in jsonSchema); this happens within `ir_validate.R`, using the package [`jsonvalidate`](https://cran.r-project.org/package=jsonvalidate). 16 | 17 | ## IR deserialisation 18 | 19 | Before using the IR we deserialise (mostly trivial, but some lists-of-objects aquire names and character vectors are simplified), which happens in `ir_deserialise.R`. 20 | 21 | ## Generation 22 | 23 | There are two paths of generation - into transpiling R and compiling C. The files for doing this start at `generate_r.R` and `generate_c.R` respectively. The end point for the the R and C generation is in `generate_r_class.R` and `generate_c_class` respectively which generates an [`R6`](https://cran.r-project.org/package=R6) class and a constructor function. 24 | -------------------------------------------------------------------------------- /tests/testthat/test-odin-build.R: -------------------------------------------------------------------------------- 1 | context("odin_build") 2 | 3 | 4 | test_that("build from validate", { 5 | skip_on_cran() 6 | model_cache_clear() 7 | options <- odin_options(verbose = TRUE, workdir = tempfile(), target = "c") 8 | code <- c("initial(x) <- 1", "deriv(x) <- 1") 9 | x <- odin_validate(code, "text") 10 | res <- odin_build(x, options) 11 | expect_is(res$model, "odin_generator") 12 | expect_is(res$output, "character") 13 | expect_identical(res$ir, x$result) 14 | expect_true(res$success) 15 | expect_null(res$error) 16 | expect_is(res$elapsed, "proc_time") 17 | }) 18 | 19 | 20 | test_that("build from ir", { 21 | skip_on_cran() 22 | model_cache_clear() 23 | options <- odin_options(verbose = TRUE, workdir = tempfile(), target = "c") 24 | code <- c("initial(x) <- 1", "deriv(x) <- 1") 25 | x <- odin_parse_(code, type = "text", options = options) 26 | res <- odin_build(x, options) 27 | expect_is(res$model, "odin_generator") 28 | expect_is(res$output, "character") 29 | expect_identical(res$ir, x) 30 | expect_true(res$success) 31 | expect_null(res$error) 32 | expect_is(res$elapsed, "proc_time") 33 | }) 34 | 35 | 36 | test_that("build failure", { 37 | skip_on_cran() 38 | code <- c("initial(x) <- 1", "deriv(x) <- 1") 39 | x <- odin_parse_(code, type = "text", options = odin_options(target = "c")) 40 | res <- odin_build(substr(x, 2, nchar(x))) 41 | expect_null(res$model) 42 | expect_is(res$error, "character") 43 | expect_false(res$success) 44 | }) 45 | 46 | 47 | test_that("invalid input", { 48 | code <- c("initial(x) <- 1", "deriv(x) <- 1") 49 | x <- odin_parse_(code, type = "text") 50 | expect_error(odin_build(as.character(x)), 51 | "Expected an odin intermediate representation") 52 | }) 53 | -------------------------------------------------------------------------------- /R/generate_r_sexp.R: -------------------------------------------------------------------------------- 1 | generate_r_sexp <- function(x, data, meta) { 2 | if (is.recursive(x)) { 3 | fn <- x[[1L]] 4 | args <- x[-1L] 5 | if (fn == "length") { 6 | generate_r_sexp(data$elements[[args[[1L]]]]$dimnames$length, 7 | data, meta) 8 | } else if (fn == "dim") { 9 | nm <- data$elements[[args[[1L]]]]$dimnames$dim[[args[[2L]]]] 10 | generate_r_sexp(nm, data, meta) 11 | } else if (fn == "odin_sum") { 12 | generate_r_sexp_sum(lapply(args, generate_r_sexp, 13 | data, meta)) 14 | } else if (fn == "norm_rand") { 15 | quote(rnorm(1L)) 16 | } else if (fn == "unif_rand") { 17 | quote(runif(1L)) 18 | } else if (fn == "exp_rand") { 19 | quote(rexp(1L)) 20 | } else { 21 | args <- lapply(args, generate_r_sexp, data, meta) 22 | if (fn %in% names(FUNCTIONS_STOCHASTIC) && fn != "rmhyper") { 23 | args <- c(list(1L), args) 24 | } 25 | if (fn == "rbinom") { 26 | args[[2L]] <- call("round", args[[2L]]) 27 | } 28 | as.call(c(list(as.name(fn)), args)) 29 | } 30 | } else if (is.character(x)) { 31 | location <- data$elements[[x]]$location 32 | if (!is.null(location) && location == "internal") { 33 | call("[[", as.name(meta$internal), x) 34 | } else { 35 | as.name(x) 36 | } 37 | } else if (is.integer(x)) { 38 | as.numeric(x) 39 | } else { 40 | x 41 | } 42 | } 43 | 44 | 45 | generate_r_sexp_sum <- function(args) { 46 | f <- function(a, b) { 47 | if (identical(a, b)) a else call("seq.int", a, b, by = 1L) 48 | } 49 | i <- seq(2L, by = 2L, to = length(args)) 50 | idx <- Map(f, args[i], args[i + 1L]) 51 | call("sum", as.call(c(list(as.name("["), args[[1L]]), idx))) 52 | } 53 | -------------------------------------------------------------------------------- /tests/testthat/examples/array_odin_user3.R: -------------------------------------------------------------------------------- 1 | age_width[] <- user() 2 | dim(age_width) <- user() 3 | 4 | N_age <- length(age_width) 5 | 6 | age_rate[1:(N_age - 1)] <- 1 / age_width[i] 7 | age_rate[N_age] <- 0 8 | 9 | den[1] <- 1 / (1 + age_rate[1] / b) 10 | ## to work out the % of the population in each age group 11 | den[2:N_age] <- age_rate[i - 1] * den[i - 1] / (age_rate[i] + b) 12 | 13 | initial(S[1:N_age]) <- den[i] * (N - I0) 14 | initial(I[1:N_age]) <- den[i] * I0 15 | initial(R[1:N_age]) <- 0 16 | 17 | I0 <- user(1) 18 | 19 | Births <- b * N 20 | b <- 1 / (365 * 50) 21 | N <- 1e7 22 | beta <- 1 23 | sigma <- 1 / 30 24 | delta <- 1 / 60 25 | 26 | I_tot <- sum(I) 27 | 28 | deriv(S[1]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 29 | (Births - age_rate[i] * S[i]) 30 | deriv(S[2:N_age]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 31 | (age_rate[i - 1] * S[i - 1] - age_rate[i] * S[i]) 32 | 33 | deriv(I[1]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 34 | (- age_rate[i] * I[i]) 35 | deriv(I[2:N_age]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 36 | (age_rate[i - 1] * I[i - 1] - age_rate[i] * I[i]) 37 | 38 | deriv(R[1]) <- sigma * I[i] - b * R[i] - delta * R[i] + 39 | (- age_rate[i] * R[i]) 40 | deriv(R[2:N_age]) <- sigma * I[i] - b * R[i] - delta * R[i] + 41 | (age_rate[i - 1] * R[i - 1] - age_rate[i] * R[i]) 42 | 43 | ## TODO: Can I get a nicer syntax here (for the N_tot case 44 | ## 45 | ## NOTE: For this sort of output variable, where things are simply 46 | ## computed from the core variables, post-processing will tend to be 47 | ## preferable I suspect. 48 | N_tot <- sum(S) + sum(I) + sum(R) 49 | output(N_tot) <- N_tot 50 | output(prev) <- I_tot / N_tot * 100 51 | 52 | dim(den) <- N_age 53 | dim(age_rate) <- N_age 54 | dim(S) <- N_age 55 | dim(I) <- N_age 56 | dim(R) <- N_age 57 | -------------------------------------------------------------------------------- /tests/testthat/helper-package.R: -------------------------------------------------------------------------------- 1 | odin_create_package <- function(name, filenames, verbose = NULL) { 2 | ## Likely to be too platform dependent for safe CRAN use 3 | testthat::skip_on_cran() 4 | verbose <- odin_options(verbose = verbose)$verbose 5 | pkg <- file.path(tempfile(), name) 6 | dir.create(pkg, FALSE, TRUE) 7 | for (f in c("DESCRIPTION", "NAMESPACE")) { 8 | writeLines(sprintf(readLines(file.path("pkg", f)), name), 9 | file.path(pkg, f)) 10 | } 11 | dir.create(file.path(pkg, "inst", "odin"), FALSE, TRUE) 12 | file.copy(filenames, file.path(pkg, "inst", "odin")) 13 | odin_package(pkg) 14 | build_package(pkg, verbose) 15 | } 16 | 17 | 18 | unload_package <- function(name) { 19 | if (name %in% loadedNamespaces()) { 20 | unloadNamespace(name) 21 | } 22 | } 23 | 24 | 25 | build_package <- function(path, verbose = TRUE) { 26 | name <- read.dcf(file.path(path, "DESCRIPTION"), "Package")[[1]] 27 | unload_package(name) 28 | if (name %in% .packages()) { 29 | detach(paste0("package:", name), unload = TRUE, character.only = TRUE) 30 | } 31 | 32 | lib <- tempfile() 33 | dir.create(lib) 34 | 35 | args <- c("CMD", "INSTALL", "-l", lib, path) 36 | Sys.setenv(R_TESTS = "") 37 | system_out <- if (isTRUE(verbose)) "" else verbose 38 | ok <- system2(file.path(R.home(), "bin", "R"), args, 39 | stdout = system_out, stderr = system_out) 40 | if (ok != 0L) { 41 | stop("Error compiling package") 42 | } 43 | 44 | cleanup <- function() { 45 | unload_package(name) 46 | unlink(dirname(path), recursive = TRUE) 47 | unlink(lib, recursive = TRUE) 48 | } 49 | 50 | loadns <- loadNamespace 51 | 52 | list(name = name, 53 | path = path, 54 | lib = lib, 55 | env = loadns(name, lib.loc = lib), 56 | cleanup = cleanup) 57 | } 58 | -------------------------------------------------------------------------------- /man/odin_parse.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/odin_parse.R 3 | \name{odin_parse} 4 | \alias{odin_parse} 5 | \alias{odin_parse_} 6 | \title{Parse an odin model} 7 | \usage{ 8 | odin_parse(x, type = NULL, options = NULL) 9 | 10 | odin_parse_(x, options = NULL, type = NULL) 11 | } 12 | \arguments{ 13 | \item{x}{An expression, character vector or filename with the odin 14 | code} 15 | 16 | \item{type}{An optional string indicating the the type of input - 17 | must be one of \code{expression}, \code{file} or \code{text} if 18 | provided. This skips the type detection code used by odin and 19 | makes validating user input easier.} 20 | 21 | \item{options}{odin options; see \link{odin_options}. The 22 | primary options that affect the parse stage are \code{validate} 23 | and \code{pretty}.} 24 | } 25 | \description{ 26 | Parse an odin model, returning an intermediate representation. 27 | The \code{odin_parse_} version is a "standard evaluation" escape 28 | hatch. 29 | } 30 | \details{ 31 | A schema for the intermediate representation is available in the 32 | package as \code{schema.json}. It is subject to change at this 33 | point. 34 | } 35 | \examples{ 36 | # Parse a model of exponential decay 37 | ir <- odin::odin_parse({ 38 | deriv(y) <- -0.5 * y 39 | initial(y) <- 1 40 | }) 41 | 42 | # This is odin's intermediate representation of the model 43 | ir 44 | 45 | # If parsing odin models programmatically, it is better to use 46 | # odin_parse_; construct the model as a string, from a file, or as a 47 | # quoted expression: 48 | code <- quote({ 49 | deriv(y) <- -0.5 * y 50 | initial(y) <- 1 51 | }) 52 | 53 | odin::odin_parse_(code) 54 | } 55 | \seealso{ 56 | \link{odin_validate}, which wraps this function 57 | where parsing might fail, and \link{odin_build} for 58 | building odin models from an intermediate representation. 59 | } 60 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGE := $(shell grep '^Package:' DESCRIPTION | sed -E 's/^Package:[[:space:]]+//') 2 | RSCRIPT = Rscript 3 | 4 | all: install 5 | 6 | test: 7 | ${RSCRIPT} -e 'library(methods); devtools::test()' 8 | 9 | test_warn: 10 | ${RSCRIPT} -e 'options(odin.compiler_warnings = TRUE); devtools::test()' 11 | 12 | test_leaks: .valgrind_ignore 13 | R -d 'valgrind --leak-check=full --suppressions=.valgrind_ignore' -e 'devtools::test()' 14 | 15 | .valgrind_ignore: 16 | R -d 'valgrind --leak-check=full --gen-suppressions=all --log-file=$@' -e 'library(testthat)' 17 | sed -i.bak '/^=/ d' $@ 18 | rm -f $@.bak 19 | 20 | roxygen: 21 | @mkdir -p man 22 | ${RSCRIPT} -e "library(methods); devtools::document()" 23 | 24 | install: 25 | R CMD INSTALL . 26 | 27 | build: 28 | R CMD build . 29 | 30 | check: 31 | _R_CHECK_CRAN_INCOMING_=FALSE make check_all 32 | 33 | check_all: 34 | ${RSCRIPT} -e "rcmdcheck::rcmdcheck(args = c('--as-cran', '--no-manual'))" 35 | 36 | autodoc: 37 | ${RSCRIPT} autodoc.R process 38 | 39 | pkgdown: 40 | ${RSCRIPT} -e "library(methods); pkgdown::build_site()" 41 | 42 | website: pkgdown 43 | ./update_web.sh 44 | 45 | README.md: README.Rmd 46 | Rscript -e 'library(methods); devtools::load_all(); knitr::knit("README.Rmd")' 47 | sed -i.bak 's/[[:space:]]*$$//' $@ 48 | rm -f $@.bak 49 | 50 | clean: 51 | rm -f src/*.o src/*.so src/*.dll 52 | 53 | coverage: 54 | Rscript -e 'covr::shine(covr::package_coverage(quiet=FALSE))' 55 | 56 | vignettes: vignettes/odin.Rmd vignettes/discrete.Rmd vignettes/functions.Rmd 57 | ${RSCRIPT} -e 'library(methods); devtools::build_vignettes()' 58 | 59 | ir_reference: 60 | ${RSCRIPT} scripts/ir-build.R 61 | 62 | javascript: 63 | ./js/build 64 | cp js/node_modules/dopri/LICENCE inst/LICENSE.dopri 65 | cp js/LICENSE.random inst/LICENSE.random 66 | 67 | # No real targets! 68 | .PHONY: all test document install vignettes build javascript 69 | -------------------------------------------------------------------------------- /tests/testthat/examples/array_odin_user.R: -------------------------------------------------------------------------------- 1 | N_age <- 5 2 | ## mean no. of days in each age compartment (0 - 1 yr, 1 - 5 yr, 5 - 3 | ## 15 yr, 15 - 30yr, 30 +) 4 | age_width[] <- user() 5 | 6 | age_rate[1:(N_age - 1)] <- 1 / age_width[i] 7 | age_rate[N_age] <- 0 8 | 9 | den[1] <- 1 / (1 + age_rate[1] / b) 10 | ## to work out the % of the population in each age group 11 | den[2:N_age] <- age_rate[i - 1] * den[i - 1] / (age_rate[i] + b) 12 | 13 | initial(S[1:N_age]) <- den[i] * (N - I0) 14 | initial(I[1:N_age]) <- den[i] * I0 15 | initial(R[1:N_age]) <- 0 16 | 17 | I0 <- user(1) 18 | 19 | Births <- b * N 20 | b <- 1 / (365 * 50) 21 | N <- 1e7 22 | beta <- 1 23 | sigma <- 1 / 30 24 | delta <- 1 / 60 25 | 26 | I_tot <- sum(I) 27 | 28 | deriv(S[1]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 29 | (Births - age_rate[i] * S[i]) 30 | deriv(S[2:N_age]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 31 | (age_rate[i - 1] * S[i - 1] - age_rate[i] * S[i]) 32 | 33 | deriv(I[1]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 34 | (- age_rate[i] * I[i]) 35 | deriv(I[2:N_age]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 36 | (age_rate[i - 1] * I[i - 1] - age_rate[i] * I[i]) 37 | 38 | deriv(R[1]) <- sigma * I[i] - b * R[i] - delta * R[i] + 39 | (- age_rate[i] * R[i]) 40 | deriv(R[2:N_age]) <- sigma * I[i] - b * R[i] - delta * R[i] + 41 | (age_rate[i - 1] * R[i - 1] - age_rate[i] * R[i]) 42 | 43 | ## TODO: Can I get a nicer syntax here (for the N_tot case 44 | ## 45 | ## NOTE: For this sort of output variable, where things are simply 46 | ## computed from the core variables, post-processing will tend to be 47 | ## preferable I suspect. 48 | N_tot <- sum(S) + sum(I) + sum(R) 49 | output(N_tot) <- N_tot 50 | output(prev) <- I_tot / N_tot * 100 51 | 52 | dim(den) <- N_age 53 | dim(age_width) <- N_age 54 | dim(age_rate) <- N_age 55 | dim(S) <- N_age 56 | dim(I) <- N_age 57 | dim(R) <- N_age 58 | -------------------------------------------------------------------------------- /tests/testthat/examples/array_odin_user2.R: -------------------------------------------------------------------------------- 1 | N_age <- user(5) 2 | ## mean no. of days in each age compartment (0 - 1 yr, 1 - 5 yr, 5 - 3 | ## 15 yr, 15 - 30yr, 30 +) 4 | age_width[] <- user() 5 | 6 | age_rate[1:(N_age - 1)] <- 1 / age_width[i] 7 | age_rate[N_age] <- 0 8 | 9 | den[1] <- 1 / (1 + age_rate[1] / b) 10 | ## to work out the % of the population in each age group 11 | den[2:N_age] <- age_rate[i - 1] * den[i - 1] / (age_rate[i] + b) 12 | 13 | initial(S[1:N_age]) <- den[i] * (N - I0) 14 | initial(I[1:N_age]) <- den[i] * I0 15 | initial(R[1:N_age]) <- 0 16 | 17 | I0 <- user(1) 18 | 19 | Births <- b * N 20 | b <- 1 / (365 * 50) 21 | N <- 1e7 22 | beta <- 1 23 | sigma <- 1 / 30 24 | delta <- 1 / 60 25 | 26 | I_tot <- sum(I) 27 | 28 | deriv(S[1]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 29 | (Births - age_rate[i] * S[i]) 30 | deriv(S[2:N_age]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 31 | (age_rate[i - 1] * S[i - 1] - age_rate[i] * S[i]) 32 | 33 | deriv(I[1]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 34 | (- age_rate[i] * I[i]) 35 | deriv(I[2:N_age]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 36 | (age_rate[i - 1] * I[i - 1] - age_rate[i] * I[i]) 37 | 38 | deriv(R[1]) <- sigma * I[i] - b * R[i] - delta * R[i] + 39 | (- age_rate[i] * R[i]) 40 | deriv(R[2:N_age]) <- sigma * I[i] - b * R[i] - delta * R[i] + 41 | (age_rate[i - 1] * R[i - 1] - age_rate[i] * R[i]) 42 | 43 | ## TODO: Can I get a nicer syntax here (for the N_tot case 44 | ## 45 | ## NOTE: For this sort of output variable, where things are simply 46 | ## computed from the core variables, post-processing will tend to be 47 | ## preferable I suspect. 48 | N_tot <- sum(S) + sum(I) + sum(R) 49 | output(N_tot) <- N_tot 50 | output(prev) <- I_tot / N_tot * 100 51 | 52 | dim(den) <- N_age 53 | dim(age_width) <- N_age 54 | dim(age_rate) <- N_age 55 | dim(S) <- N_age 56 | dim(I) <- N_age 57 | dim(R) <- N_age 58 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-differentiate.R: -------------------------------------------------------------------------------- 1 | test_that("Can parse with differentiable parameters", { 2 | ir <- odin_parse({ 3 | initial(x) <- 1 4 | update(x) <- rnorm(0, 0.1) 5 | d <- data() 6 | compare(d) ~ normal(0, scale) 7 | scale <- user(differentiate = TRUE) 8 | }) 9 | 10 | d <- ir_deserialise(ir) 11 | expect_true(d$features$has_derivative) 12 | }) 13 | 14 | 15 | test_that("can't differentiate integer parameters", { 16 | expect_error(odin_parse({ 17 | initial(x) <- 1 18 | update(x) <- rnorm(0, 0.1) 19 | d <- data() 20 | compare(d) ~ normal(x, scale) 21 | scale <- user(differentiate = TRUE, integer = TRUE) 22 | }), 23 | "Can't differentiate integer parameters\\s+scale <-") 24 | }) 25 | 26 | 27 | test_that("can't differentiate without compare", { 28 | expect_error( 29 | odin_parse({ 30 | initial(x) <- 1 31 | update(x) <- rnorm(x, scale) 32 | scale <- user(differentiate = TRUE) 33 | }), 34 | "You need a compare expression to differentiate!\\s+scale <-") 35 | }) 36 | 37 | 38 | test_that("can't differentiate continuous time models", { 39 | expect_error( 40 | odin_parse({ 41 | initial(x) <- 1 42 | deriv(x) <- 1 43 | d <- data() 44 | compare(d) ~ normal(x, scale) 45 | scale <- user(differentiate = TRUE) 46 | }), 47 | "Can't use differentiate with continuous time models\\s+scale <-") 48 | }) 49 | 50 | 51 | test_that("can't differentiate models with arrays", { 52 | err <- expect_error( 53 | odin_parse({ 54 | initial(x[]) <- 1 55 | update(x[]) <- rnorm(x, 1) 56 | dim(x) <- 5 57 | d <- data() 58 | compare(d) ~ normal(sum(x), scale) 59 | scale <- user(differentiate = TRUE) 60 | }), 61 | "Can't use differentiate with models that use arrays") 62 | expect_match(err$message, "dim(x) <-", fixed = TRUE) 63 | expect_match(err$message, "scale <-", fixed = TRUE) 64 | }) 65 | -------------------------------------------------------------------------------- /man/odin_package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/odin_package.R 3 | \name{odin_package} 4 | \alias{odin_package} 5 | \title{Create odin model in a package} 6 | \usage{ 7 | odin_package(path_package) 8 | } 9 | \arguments{ 10 | \item{path_package}{Path to the package root (the directory that 11 | contains \code{DESCRIPTION})} 12 | } 13 | \description{ 14 | Create an odin model within an existing package. 15 | } 16 | \details{ 17 | I am resisting the urge to actually create the package here. 18 | There are better options than I can come up with; for example 19 | \code{devtools::create}, \code{pkgkitten::kitten}, \code{mason::mason}, or 20 | creating \code{DESCRIPTION} files using \code{desc}. What is required here 21 | is that your package: 22 | \itemize{ 23 | \item Lists \code{odin} in \verb{Imports:} 24 | \item Includes \verb{useDynLib()} in 25 | \code{NAMESPACE} (possibly via a roxygen comment \verb{@useDynLib } 26 | \item To avoid a NOTE in \verb{R CMD check}, import something from 27 | \code{odin} in your namespace (e.g., \code{importFrom("odin", "odin")}s 28 | or roxygen \verb{@importFrom(odin, odin)} 29 | } 30 | 31 | Point this function at the package root (the directory containing 32 | \code{DESCRIPTION} and it will write out files \code{src/odin.c} 33 | and \code{odin.R}. These files will be overwritten without 34 | warning by running this again. 35 | } 36 | \examples{ 37 | path <- tempfile() 38 | dir.create(path) 39 | 40 | src <- system.file("examples/package", package = "odin", mustWork = TRUE) 41 | file.copy(src, path, recursive = TRUE) 42 | pkg <- file.path(path, "package") 43 | 44 | # The package is minimal: 45 | dir(pkg) 46 | 47 | # But contains odin files in inst/odin 48 | dir(file.path(pkg, "inst/odin")) 49 | 50 | # Compile the odin code in the package 51 | odin::odin_package(pkg) 52 | 53 | # Which creates the rest of the package structure 54 | dir(pkg) 55 | dir(file.path(pkg, "R")) 56 | dir(file.path(pkg, "src")) 57 | } 58 | -------------------------------------------------------------------------------- /tests/testthat/examples/array_odin.R: -------------------------------------------------------------------------------- 1 | N_age <- 5 2 | ## mean no. of days in each age compartment (0 - 1 yr, 1 - 5 yr, 5 - 3 | ## 15 yr, 15 - 30yr, 30 +) 4 | age_width[1] <- 365 * 1 5 | age_width[2] <- 365 * 4 6 | age_width[3] <- 365 * 10 7 | age_width[4] <- 365 * 15 8 | age_width[5] <- 365 * 20 9 | 10 | age_rate[1:(N_age - 1)] <- 1 / age_width[i] 11 | age_rate[N_age] <- 0 12 | 13 | den[1] <- 1 / (1 + age_rate[1] / b) 14 | ## to work out the % of the population in each age group 15 | den[2:N_age] <- age_rate[i - 1] * den[i - 1] / (age_rate[i] + b) 16 | 17 | initial(S[1:N_age]) <- den[i] * (N - I0) 18 | initial(I[1:N_age]) <- den[i] * I0 19 | initial(R[1:N_age]) <- 0 20 | 21 | I0 <- user(1) 22 | 23 | Births <- b * N 24 | b <- 1 / (365 * 50) 25 | N <- 1e7 26 | beta <- 1 27 | sigma <- 1 / 30 28 | delta <- 1 / 60 29 | 30 | I_tot <- sum(I) 31 | 32 | deriv(S[1]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 33 | (Births - age_rate[i] * S[i]) 34 | deriv(S[2:N_age]) <- - beta * S[i] * I_tot / N + delta * R[i] - b * S[i] + 35 | (age_rate[i - 1] * S[i - 1] - age_rate[i] * S[i]) 36 | 37 | deriv(I[1]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 38 | (- age_rate[i] * I[i]) 39 | deriv(I[2:N_age]) <- beta * S[i] * I_tot / N - (b + sigma) * I[i] + 40 | (age_rate[i - 1] * I[i - 1] - age_rate[i] * I[i]) 41 | 42 | deriv(R[1]) <- sigma * I[i] - b * R[i] - delta * R[i] + 43 | (- age_rate[i] * R[i]) 44 | deriv(R[2:N_age]) <- sigma * I[i] - b * R[i] - delta * R[i] + 45 | (age_rate[i - 1] * R[i - 1] - age_rate[i] * R[i]) 46 | 47 | ## TODO: Can I get a nicer syntax here (for the N_tot case 48 | ## 49 | ## NOTE: For this sort of output variable, where things are simply 50 | ## computed from the core variables, post-processing will tend to be 51 | ## preferable I suspect. 52 | N_tot <- sum(S) + sum(I) + sum(R) 53 | output(N_tot) <- N_tot 54 | output(prev) <- I_tot / N_tot * 100 55 | 56 | dim(den) <- N_age 57 | dim(age_width) <- N_age 58 | dim(age_rate) <- N_age 59 | dim(S) <- N_age 60 | dim(I) <- N_age 61 | dim(R) <- N_age 62 | -------------------------------------------------------------------------------- /tests/testthat/logs/gcc_error.txt: -------------------------------------------------------------------------------- 1 | gcc -std=gnu99 -I/usr/share/R/include -DNDEBUG -fpic -g -O2 -fstack-protector --param=ssp-buffer-size=4 -Wformat -Werror=format-security -D_FORTIFY_SOURCE=2 -g -c odin7040168aaaaa.c -o odin7040168aaaaa.o 2 | odin7040168aaaaa.c:25:57: error: unknown type name ‘bool’ 3 | double* get_user_array_dim(SEXP user, const char *name, bool is_real, int nd, int *dest_dim); 4 | ^ 5 | odin7040168aaaaa.c:27:53: error: unknown type name ‘bool’ 6 | void get_user_array_copy(SEXP el, const char *name, bool is_real, void *dest); 7 | ^ 8 | odin7040168aaaaa.c: In function ‘odin7040168aaaaa_set_user’: 9 | odin7040168aaaaa.c:51:5: warning: implicit declaration of function ‘get_user_array_dim’ [-Wimplicit-function-declaration] 10 | double *tmp = get_user_array_dim(user, "x", true, 1, &odin7040168aaaaa_p->dim_x); 11 | ^ 12 | odin7040168aaaaa.c:51:49: error: ‘true’ undeclared (first use in this function) 13 | double *tmp = get_user_array_dim(user, "x", true, 1, &odin7040168aaaaa_p->dim_x); 14 | ^ 15 | odin7040168aaaaa.c:51:49: note: each undeclared identifier is reported only once for each function it appears in 16 | odin7040168aaaaa.c:57:48: error: ‘false’ undeclared (first use in this function) 17 | int *tmp = get_user_array_dim(user, "idx", false, 1, &odin7040168aaaaa_p->dim_idx); 18 | ^ 19 | odin7040168aaaaa.c: At top level: 20 | odin7040168aaaaa.c:204:57: error: unknown type name ‘bool’ 21 | double* get_user_array_dim(SEXP user, const char *name, bool is_real, int nd, int *dest_dim) { 22 | ^ 23 | odin7040168aaaaa.c:252:53: error: unknown type name ‘bool’ 24 | void get_user_array_copy(SEXP el, const char *name, bool is_real, void *dest) { 25 | ^ 26 | make: *** [odin7040168aaaaa.o] Error 1 27 | -------------------------------------------------------------------------------- /R/ring_cache.R: -------------------------------------------------------------------------------- 1 | ## This memoises some calls within interface.R so that we can avoid 2 | ## some expensive operations. We could probably use a single cache 3 | ## but that's somewhat complicated by trying to avoid recompiling 4 | ## between sessions (and doing things like clobbering dlls that have 5 | ## been loaded by another process). 6 | ## 7 | ## A small R6 class that allows for a very basic ring-like interface. 8 | ## I might move something like this into ring at some point 9 | ## (https://github.com/richfitz/ring/issues/11) given it's a pain to 10 | ## test and it's the sort of thing that ring should really support 11 | ## (and we depend on it already!) 12 | ## 13 | ## The other way of doing this would be to order the access times 14 | R6_ring_cache <- R6::R6Class( 15 | "ring_cache", 16 | 17 | public = list( 18 | capacity = NULL, 19 | data = NULL, 20 | 21 | initialize = function(capacity) { 22 | self$capacity <- capacity 23 | self$clear() 24 | }, 25 | 26 | clear = function() { 27 | self$data <- set_names(list(), character()) 28 | }, 29 | 30 | put = function(key, value) { 31 | new <- set_names(list(value), key) 32 | if (key %in% names(self$data)) { 33 | self$promote(key) 34 | } else if (length(self$data) >= self$capacity) { 35 | self$data <- c(new, self$data[seq_len(self$capacity) - 1L]) 36 | } else { 37 | self$data <- c(new, self$data) 38 | } 39 | }, 40 | 41 | get = function(key) { 42 | ret <- self$data[[key]] 43 | if (!is.null(ret)) { 44 | self$promote(key) 45 | } 46 | ret 47 | }, 48 | 49 | promote = function(key) { 50 | self$data <- self$data[c(key, setdiff(names(self$data), key))] 51 | }, 52 | 53 | list = function() { 54 | names(self$data) 55 | }, 56 | 57 | resize = function(capacity) { 58 | if (capacity < length(self$data)) { 59 | self$data <- self$data[seq_len(capacity)] 60 | } 61 | self$capacity <- capacity 62 | } 63 | )) 64 | -------------------------------------------------------------------------------- /tests/testthat/examples/array_2d_odin.R: -------------------------------------------------------------------------------- 1 | N_age <- 5 2 | ## mean no. of days in each age compartment (0 - 1 yr, 1 - 5 yr, 5 - 3 | ## 15 yr, 15 - 30yr, 30 +) 4 | age_width[1] <- 365 * 1 5 | age_width[2] <- 365 * 4 6 | age_width[3] <- 365 * 10 7 | age_width[4] <- 365 * 15 8 | age_width[5] <- 365 * 20 9 | 10 | age_rate[1:(N_age - 1)] <- 1 / age_width[i] 11 | age_rate[N_age] <- 0 12 | 13 | den[1] <- 1 / (1 + age_rate[1] / b) 14 | ## to work out the % of the population in each age group 15 | den[2:N_age] <- age_rate[i - 1] * den[i - 1] / (age_rate[i] + b) 16 | 17 | initial(y[1:N_age, 1]) <- den[i] * (N - I0) 18 | initial(y[1:N_age, 2]) <- den[i] * I0 19 | initial(y[1:N_age, 3]) <- 0 20 | 21 | I0 <- user(1) 22 | 23 | Births <- b * N 24 | b <- 1 / (365 * 50) 25 | N <- 1e7 26 | beta <- 1 27 | sigma <- 1 / 30 28 | delta <- 1 / 60 29 | 30 | I_tot <- sum(y[, 2]) 31 | 32 | deriv(y[1, 1]) <- - beta * y[i, 1] * I_tot / N + delta * y[i, 3] - b * y[i, 1] + 33 | (Births - age_rate[i] * y[i, 1]) 34 | deriv(y[2:N_age, 1]) <- - beta * y[i, 1] * I_tot / N + delta * y[i, 3] - 35 | b * y[i, 1] + (age_rate[i - 1] * y[i - 1, 1] - age_rate[i] * y[i, 1]) 36 | 37 | deriv(y[1, 2]) <- beta * y[i, 1] * I_tot / N - (b + sigma) * y[i, 2] + 38 | (- age_rate[i] * y[i, 2]) 39 | deriv(y[2:N_age, 2]) <- beta * y[i, 1] * I_tot / N - (b + sigma) * y[i, 2] + 40 | (age_rate[i - 1] * y[i - 1, 2] - age_rate[i] * y[i, 2]) 41 | 42 | deriv(y[1, 3]) <- sigma * y[i, 2] - b * y[i, 3] - delta * y[i, 3] + 43 | (- age_rate[i] * y[i, 3]) 44 | deriv(y[2:N_age, 3]) <- sigma * y[i, 2] - b * y[i, 3] - delta * y[i, 3] + 45 | (age_rate[i - 1] * y[i - 1, 3] - age_rate[i] * y[i, 3]) 46 | 47 | ## TODO: Can I get a nicer syntax here (for the N_tot case 48 | ## 49 | ## NOTE: For this sort of output variable, where things are simply 50 | ## computed from the core variables, post-processing will tend to be 51 | ## preferable I suspect. 52 | N_tot <- sum(y) 53 | output(N_tot) <- N_tot 54 | output(prev) <- I_tot / N_tot * 100 55 | 56 | dim(den) <- N_age 57 | dim(age_width) <- N_age 58 | dim(age_rate) <- N_age 59 | dim(y) <- c(N_age, 3) 60 | -------------------------------------------------------------------------------- /tests/testthat/examples/seir_array_odin.R: -------------------------------------------------------------------------------- 1 | N_age <- 5 2 | ## mean no. of days in each age compartment (0 - 1 yr, 1 - 5 yr, 5 - 3 | ## 15 yr, 15 - 30yr, 30 +) 4 | age_width[1] <- 365 * 1 5 | age_width[2] <- 365 * 4 6 | age_width[3] <- 365 * 10 7 | age_width[4] <- 365 * 15 8 | age_width[5] <- 365 * 20 9 | 10 | age_rate[1:(N_age - 1)] <- 1 / age_width[i] 11 | age_rate[N_age] <- 0 12 | 13 | den[1] <- 1 / (1 + age_rate[1] / b) 14 | ## to work out the % of the population in each age group 15 | den[2:N_age] <- age_rate[i - 1] * den[i - 1] / (age_rate[i] + b) 16 | 17 | initial(S[1:N_age]) <- den[i] * (N - I0) 18 | initial(E[1:N_age]) <- 0 19 | initial(I[1:N_age]) <- den[i] * I0 20 | initial(R[1:N_age]) <- 0 21 | 22 | I0 <- user(1) 23 | 24 | Births <- b * N 25 | b <- 1 / (365 * 50) 26 | N <- 1e7 27 | beta <- 1 28 | sigma <- 1 / 30 29 | delta <- 1 / 60 30 | lat_hum <- 14 31 | 32 | I_tot <- sum(I) 33 | 34 | surv <- exp(-b * lat_hum) 35 | new_inf[] <- beta * S[i] * I_tot / N 36 | lag_inf[] <- delay(new_inf[i] * surv, lat_hum) 37 | 38 | deriv(S[1]) <- - new_inf[i] + delta * R[i] - b * S[i] + 39 | (Births - age_rate[i] * S[i]) 40 | deriv(S[2:N_age]) <- - new_inf[i] + delta * R[i] - b * S[i] + 41 | (age_rate[i - 1] * S[i - 1] - age_rate[i] * S[i]) 42 | 43 | deriv(E[1]) <- new_inf[i] - lag_inf[i] - b * E[i] + (- age_rate[i] * E[i]) 44 | deriv(E[2:N_age]) <- new_inf[i] - lag_inf[i] - b * E[i] + 45 | (age_rate[i - 1] * E[i - 1] - age_rate[i] * E[i]) 46 | 47 | deriv(I[1]) <- lag_inf[i] - (b + sigma) * I[i] + 48 | (- age_rate[i] * I[i]) 49 | deriv(I[2:N_age]) <- lag_inf[i] - (b + sigma) * I[i] + 50 | (age_rate[i - 1] * I[i - 1] - age_rate[i] * I[i]) 51 | 52 | deriv(R[1]) <- sigma * I[i] - b * R[i] - delta * R[i] + 53 | (- age_rate[i] * R[i]) 54 | deriv(R[2:N_age]) <- sigma * I[i] - b * R[i] - delta * R[i] + 55 | (age_rate[i - 1] * R[i - 1] - age_rate[i] * R[i]) 56 | 57 | dim(den) <- N_age 58 | dim(age_width) <- N_age 59 | dim(age_rate) <- N_age 60 | dim(S) <- N_age 61 | dim(E) <- N_age 62 | dim(I) <- N_age 63 | dim(R) <- N_age 64 | 65 | dim(new_inf) <- N_age 66 | dim(lag_inf) <- N_age 67 | -------------------------------------------------------------------------------- /tests/testthat/test-run-debug.R: -------------------------------------------------------------------------------- 1 | test_that_odin("print unconditional debugging", { 2 | skip_for_target("js") 3 | gen <- odin({ 4 | deriv(x) <- 1 5 | initial(x) <- 0 6 | print("x: {x}") 7 | }, debug_enable = TRUE) 8 | 9 | out <- capture_output(res <- gen$new()$run(0:5)) 10 | expect_true(nzchar(out)) 11 | out <- strsplit(out, "\n")[[1]] 12 | expect_match(out, "^\\[[0-9.]+\\] x: [0-9.]+$") 13 | }) 14 | 15 | 16 | test_that_odin("don't print debugging if not enabled", { 17 | skip_for_target("js") 18 | gen <- odin({ 19 | deriv(x) <- 1 20 | initial(x) <- 0 21 | print("x: {x}") 22 | }, debug_enable = FALSE, skip_cache = TRUE) 23 | 24 | out <- capture_output(res <- gen$new()$run(0:5)) 25 | expect_false(nzchar(out)) 26 | }) 27 | 28 | 29 | test_that_odin("print debug based on condition", { 30 | skip_for_target("js") 31 | gen <- odin({ 32 | deriv(x) <- 1 33 | initial(x) <- 0 34 | print("x: {x}", when = x > 1 && x < 4) 35 | }, debug_enable = TRUE) 36 | out <- capture_output(res <- gen$new()$run(0:5)) 37 | expect_true(nzchar(out)) 38 | out <- strsplit(out, "\n")[[1]] 39 | x <- as.numeric(sub(".+x: ", "", out)) 40 | expect_true(all(x > 1 & x < 4)) 41 | }) 42 | 43 | 44 | test_that_odin("format to different levels of precision", { 45 | skip_for_target("js") 46 | gen <- odin({ 47 | deriv(x) <- 1 48 | initial(x) <- 0 49 | print("{x; .2f} {x; .4f} {x; .6f}") 50 | }, debug_enable = TRUE) 51 | out <- capture_output(res <- gen$new()$run(0:5)) 52 | expect_true(nzchar(out)) 53 | out <- strsplit(out, "\n")[[1]] 54 | expect_match( 55 | out, 56 | "^\\[[0-9]\\.[0-9]+\\] [0-9]\\.[0-9]{2} [0-9]\\.[0-9]{4} [0-9]\\.[0-9]{6}") 57 | }) 58 | 59 | 60 | test_that_odin("print debugging in discrete time model", { 61 | skip_for_target("js") 62 | gen <- odin({ 63 | update(x) <- x + 1 64 | initial(x) <- 0 65 | print("x: {x; .0f}") 66 | }, debug_enable = TRUE) 67 | 68 | out <- capture_output(res <- gen$new()$run(0:5)) 69 | expect_true(nzchar(out)) 70 | out <- strsplit(out, "\n")[[1]] 71 | expect_equal(out, sprintf("[%d] x: %d", 0:4, 0:4)) 72 | }) 73 | -------------------------------------------------------------------------------- /tests/testthat/examples/array_deSolve.R: -------------------------------------------------------------------------------- 1 | age <- function() { 2 | b <- 1 / (365 * 50) 3 | N <- 1e7 4 | I0 <- 1 5 | Births <- b * N 6 | beta <- 1 7 | sigma <- 1 / 30 8 | delta <- 1 / 60 9 | 10 | N_age <- 5L 11 | age_width <- c(1, 4, 10, 15, 20) * 365 12 | age_rate <- c(1 / age_width[-N_age], 0.0) 13 | 14 | ## to work out the % of the population in each age group 15 | den <- numeric(N_age) 16 | den[[1L]] <- 1.0 / (1.0 + age_rate[[1L]] / b) 17 | for (i in 2:N_age) { 18 | den[i] <- age_rate[[i - 1L]] * den[[i - 1L]] / (age_rate[i] + b) 19 | } 20 | 21 | initial <- function(t = 0, pars = NULL) { 22 | if ("I0" %in% names(pars)) { 23 | I0 <<- pars$I0 24 | } 25 | S0 <- den * (N - I0) 26 | I0 <- den * I0 27 | R0 <- den * 0 28 | ret <- c(S0, I0, R0) 29 | attr(ret, "output_len") <- 2L 30 | ret 31 | } 32 | 33 | derivs <- function(t, y, .) { 34 | y <- matrix(y, N_age, 3L) 35 | S <- y[, 1L] 36 | I <- y[, 2L] 37 | R <- y[, 3L] 38 | dSdt <- numeric(N_age) 39 | dIdt <- numeric(N_age) 40 | dRdt <- numeric(N_age) 41 | I_tot <- sum(I) 42 | 43 | dSdt[[1L]] <- - beta * S[[1L]] * I_tot / N + delta * R[[1L]] - b * S[[1L]] + 44 | (Births - age_rate[[1L]] * S[[1L]]) 45 | dSdt[-1L] <- - beta * S[-1L] * I_tot / N + delta * R[-1L] - b * S[-1L] + 46 | (age_rate[-N_age] * S[-N_age] - age_rate[-1L] * S[-1L]) 47 | 48 | dIdt[[1L]] <- beta * S[[1L]] * I_tot / N - (b + sigma) * I[[1L]] + 49 | (-age_rate[[1L]] * I[[1L]]) 50 | dIdt[-1L] <- beta * S[-1L] * I_tot / N - (b + sigma) * I[-1L] + 51 | (age_rate[-N_age] * I[-N_age] - age_rate[-1L] * I[-1L]) 52 | 53 | dRdt[[1L]] <- sigma * I[[1L]] - b * R[[1L]] - delta * R[[1L]] + 54 | (-age_rate[[1L]] * R[[1L]]) 55 | dRdt[-1L] <- sigma * I[-1L] - b * R[-1L] - delta * R[-1L] + 56 | (age_rate[-N_age] * R[-N_age] - age_rate[-1L] * R[-1L]) 57 | 58 | N_tot <- sum(S + I + R) 59 | prev <- I_tot / N_tot * 100 60 | list(c(dSdt, dIdt, dRdt), 61 | c(N_tot = N_tot, prev = prev)) 62 | } 63 | 64 | list(derivs = derivs, initial = initial, t = c(0, 100)) 65 | } 66 | -------------------------------------------------------------------------------- /man/odin_build.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/odin_build.R 3 | \name{odin_build} 4 | \alias{odin_build} 5 | \title{Build an odin model generator from its IR} 6 | \usage{ 7 | odin_build(x, options = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{An odin ir (json) object or output from 11 | \link{odin_validate}.} 12 | 13 | \item{options}{Options to pass to the build stage (see 14 | \link{odin_options}} 15 | } 16 | \description{ 17 | Build an odin model generator from its intermediate 18 | representation, as generated by \link{odin_parse}. This 19 | function is for advanced use. 20 | } 21 | \details{ 22 | In applications that want to inspect the intermediate 23 | representation rather before compiling, rather than directly using 24 | \link{odin}, use either \link{odin_parse} or 25 | \link{odin_validate} and then pass the result to 26 | \code{odin::odin_build}. 27 | 28 | The return value of this function includes information about how 29 | long the compilation took, if it was successful, etc, in the same 30 | style as \link{odin_validate}: 31 | 32 | \describe{ 33 | \item{success}{Logical, indicating if compilation was successful} 34 | 35 | \item{elapsed}{Time taken to compile the model, as a 36 | \code{proc_time} object, as returned by \link{proc.time}.} 37 | 38 | \item{output}{Any output produced when compiling the model (only 39 | present if compiling to C, and if the cache was not hit.} 40 | 41 | \item{model}{The model itself, as an \code{odin_generator} object, 42 | as returned by \link{odin}.} 43 | 44 | \item{ir}{The intermediate representation.} 45 | 46 | \item{error}{Any error thrown during compilation} 47 | } 48 | } 49 | \examples{ 50 | # Parse a model of exponential decay 51 | ir <- odin::odin_parse({ 52 | deriv(y) <- -0.5 * y 53 | initial(y) <- 1 54 | }) 55 | 56 | # Compile the model: 57 | options <- odin::odin_options(target = "r") 58 | res <- odin::odin_build(ir, options) 59 | 60 | # All results: 61 | res 62 | 63 | # The model: 64 | mod <- res$model$new() 65 | mod$run(0:10) 66 | } 67 | \seealso{ 68 | \link{odin_parse}, which creates intermediate 69 | representations used by this function. 70 | } 71 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: odin 2 | Title: ODE Generation and Integration 3 | Version: 1.5.11 4 | Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"), 5 | email = "rich.fitzjohn@gmail.com"), 6 | person("Thibaut", "Jombart", role = "ctb"), 7 | person("Imperial College of Science, Technology and Medicine", 8 | role = "cph")) 9 | Description: Generate systems of ordinary differential equations 10 | (ODE) and integrate them, using a domain specific language 11 | (DSL). The DSL uses R's syntax, but compiles to C in order to 12 | efficiently solve the system. A solver is not provided, but 13 | instead interfaces to the packages 'deSolve' and 'dde' are 14 | generated. With these, while solving the differential equations, 15 | no allocations are done and the calculations remain entirely in 16 | compiled code. Alternatively, a model can be transpiled to R for 17 | use in contexts where a C compiler is not present. After 18 | compilation, models can be inspected to return information about 19 | parameters and outputs, or intermediate values after calculations. 20 | 'odin' is not targeted at any particular domain and is suitable 21 | for any system that can be expressed primarily as mathematical 22 | expressions. Additional support is provided for working with 23 | delays (delay differential equations, DDE), using interpolated 24 | functions during interpolation, and for integrating quantities 25 | that represent arrays. 26 | License: MIT + file LICENSE 27 | URL: https://github.com/mrc-ide/odin 28 | BugReports: https://github.com/mrc-ide/odin/issues 29 | Imports: 30 | R6, 31 | cinterpolate (>= 1.0.0), 32 | deSolve, 33 | digest, 34 | glue, 35 | jsonlite, 36 | ring, 37 | withr 38 | Suggests: 39 | V8, 40 | dde (>= 1.0.0), 41 | jsonvalidate (>= 1.1.0), 42 | knitr, 43 | mockery, 44 | pkgbuild, 45 | pkgload, 46 | rlang, 47 | rmarkdown, 48 | testthat 49 | VignetteBuilder: knitr 50 | RoxygenNote: 7.2.3 51 | Roxygen: list(old_usage = TRUE, markdown = TRUE) 52 | Encoding: UTF-8 53 | Language: en-GB 54 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-interpolation.R: -------------------------------------------------------------------------------- 1 | context("parse: interpolation") 2 | 3 | test_that("interpolation parse errors: incorrect array dimension", { 4 | expect_error(odin_parse({ 5 | deriv(y[]) <- pulse[i] 6 | initial(y[]) <- 0 7 | ## 8 | pulse[] <- interpolate(tp, zp, "constant") 9 | ## 10 | tp[] <- user() 11 | zp[] <- user() 12 | dim(tp) <- user() 13 | dim(zp) <- user() 14 | dim(pulse) <- 2 15 | dim(y) <- 2 16 | }), 17 | "Expected zp to be a 2 dimensional array", class = "odin_error") 18 | 19 | expect_error(odin_parse({ 20 | deriv(y[]) <- pulse[i] 21 | initial(y[]) <- 0 22 | ## 23 | pulse[] <- interpolate(tp, zp, "constant") 24 | ## 25 | tp[] <- user() 26 | zp[, , ] <- user() 27 | dim(tp) <- user() 28 | dim(zp) <- user() 29 | dim(pulse) <- 2 30 | dim(y) <- 2 31 | }), 32 | "Expected zp to be a 2 dimensional array", class = "odin_error") 33 | 34 | expect_error(odin_parse({ 35 | deriv(y[]) <- pulse[i] 36 | initial(y[]) <- 0 37 | ## 38 | pulse[] <- interpolate(tp, zp, "constant") 39 | ## 40 | tp[, ] <- user() 41 | zp[, ] <- user() 42 | dim(tp) <- user() 43 | dim(zp) <- user() 44 | dim(pulse) <- 2 45 | dim(y) <- 2 46 | }), 47 | "Expected tp to be a vector", class = "odin_error") 48 | }) 49 | 50 | 51 | test_that("unknown interpolation variable", { 52 | expect_error(odin_parse({ 53 | deriv(y[]) <- pulse[i] 54 | initial(y[]) <- 0 55 | ## 56 | pulse[] <- interpolate(tp, zp, "constant") 57 | ## 58 | tp[] <- user() 59 | dim(tp) <- user() 60 | dim(pulse) <- 2 61 | dim(y) <- 2 62 | }), 63 | "Unknown variable zp", class = "odin_error") 64 | }) 65 | 66 | 67 | test_that("interpolation array assignment error", { 68 | expect_error(odin_parse({ 69 | deriv(y[]) <- pulse[i] 70 | initial(y[]) <- 0 71 | ## 72 | pulse[] <- interpolate(tp, zp, "constant") 73 | pulse[2] <- 3 74 | ## 75 | tp[] <- user() 76 | dim(tp) <- user() 77 | dim(pulse) <- 2 78 | dim(y) <- 2 79 | }), 80 | "interpolate() may only be used on a single-line array", 81 | fixed = TRUE, class = "odin_error") 82 | }) 83 | -------------------------------------------------------------------------------- /R/interface.R: -------------------------------------------------------------------------------- 1 | ##' Return detailed information about an odin model. This is the 2 | ##' mechanism through which [coef] works with odin. 3 | ##' 4 | ##' @section Warning: 5 | ##' 6 | ##' The returned data is subject to change for a few versions while I 7 | ##' work out how we'll use it. 8 | ##' 9 | ##' @title Return detailed information about an odin model 10 | ##' 11 | ##' @param x An `odin_generator` function, as created by 12 | ##' `odin::odin` 13 | ##' 14 | ##' @param parsed Logical, indicating if the representation should be 15 | ##' parsed and converted into an R object. If `FALSE` we 16 | ##' return a json string. 17 | ##' 18 | ##' @export 19 | ##' @examples 20 | ##' exp_decay <- odin::odin({ 21 | ##' deriv(y) <- -0.5 * y 22 | ##' initial(y) <- 1 23 | ##' }, target = "r") 24 | ##' odin::odin_ir(exp_decay) 25 | ##' coef(exp_decay) 26 | odin_ir <- function(x, parsed = FALSE) { 27 | if (inherits(x, "odin_generator")) { 28 | ir <- attr(x, "ir") %||% attr(x, "generator")$public_methods$ir() 29 | } else if (inherits(x, "odin_model")) { 30 | ir <- x$ir() 31 | } else { 32 | stop("Expected an odin_generator or odin_model object") 33 | } 34 | 35 | if (parsed) { 36 | ir <- ir_deserialise(ir) 37 | } 38 | ir 39 | } 40 | 41 | 42 | ##' @export 43 | ##' @importFrom stats coef 44 | coef.odin_generator <- function(object, ...) { 45 | dat <- odin_ir(object, TRUE) 46 | 47 | name <- names(dat$user) 48 | user <- unname(dat$equations[name]) 49 | default_value <- unname(lapply(user, function(x) x$user$default)) 50 | has_default <- !vlapply(default_value, is.null) 51 | min <- vnapply(user, function(x) x$user$min %||% -Inf) 52 | max <- vnapply(user, function(x) x$user$max %||% Inf) 53 | integer <- vlapply(user, function(x) x$user$integer %||% FALSE) 54 | rank <- viapply(dat$data$elements[name], "[[", "rank", USE.NAMES = FALSE) 55 | 56 | data.frame(name = name, 57 | has_default = has_default, 58 | default_value = I(default_value), 59 | rank = rank, 60 | min = min, 61 | max = max, 62 | integer = integer, 63 | stringsAsFactors = FALSE) 64 | } 65 | 66 | 67 | ##' @export 68 | coef.odin_model <- coef.odin_generator 69 | -------------------------------------------------------------------------------- /tests/testthat/helper-js.R: -------------------------------------------------------------------------------- 1 | call_odin_bundle_continuous <- function(bundle, user, t0, t1, tn, 2 | control = NULL) { 3 | stopifnot(!bundle$is_discrete) 4 | 5 | ct <- V8::v8() 6 | ct$eval(bundle$support) 7 | ct$eval(bundle$model$code) 8 | ct$source(odin_file("js/test-continuous.js")) 9 | odin_js <- V8::JS(bundle$model$name) 10 | user_js <- to_js_user(user) 11 | 12 | if (length(control) == 0) { 13 | control_js <- V8::JS("{}") 14 | } else { 15 | control_js <- V8::JS(jsonlite::toJSON(control, auto_unbox = TRUE)) 16 | } 17 | 18 | ct$call("call_odin_bundle", odin_js, user_js, t0, t1, tn, control_js) 19 | } 20 | 21 | 22 | call_odin_bundle_discrete <- function(bundle, user, t0, t1, dt, n_particles) { 23 | stopifnot(bundle$is_discrete) 24 | 25 | ct <- V8::v8() 26 | ct$eval(bundle$support) 27 | ct$eval(bundle$model$code) 28 | ct$source(odin_file("js/test-discrete.js")) 29 | odin_js <- V8::JS(bundle$model$name) 30 | user_js <- to_js_user(user) 31 | 32 | ct$call("call_odin_bundle", odin_js, user_js, t0, t1, dt, n_particles) 33 | } 34 | 35 | 36 | to_json_max <- function(x) { 37 | V8::JS(jsonlite::toJSON(x, digits = NA)) 38 | } 39 | 40 | 41 | model_context <- function(x) { 42 | environment(x$initialize)$private$context 43 | } 44 | 45 | 46 | model_set_seed <- function(mod, seed) { 47 | if (mod$engine() == "js") { 48 | model_context(mod)$call("setSeed", seed) 49 | } else { 50 | set.seed(seed) 51 | } 52 | } 53 | 54 | 55 | model_random_numbers <- function(mod, name, n, ...) { 56 | stopifnot(mod$engine() == "js") 57 | ctx <- V8::v8() 58 | ctx$source(odin_file("js/dust.js")) 59 | ctx$source("random.js") 60 | jsonlite::fromJSON(ctx$call("random", name, n, list(...))) 61 | } 62 | 63 | 64 | to_json_columnwise <- function(x) { 65 | V8::JS(jsonlite::toJSON(x, matrix = "columnmajor")) 66 | } 67 | 68 | 69 | skip_if_no_js <- function() { 70 | skip_if_not_installed("V8") 71 | ## Historically we've had issues with the non-standard V8 build on 72 | ## Fedora, it's not documented what is different there, but it 73 | ## behaves poorly. 74 | skip_on_cran() 75 | } 76 | 77 | list_to_matrix <- function(x) { 78 | matrix(unlist(x), ncol = length(x)) 79 | } 80 | -------------------------------------------------------------------------------- /R/odin_parse.R: -------------------------------------------------------------------------------- 1 | ##' Parse an odin model, returning an intermediate representation. 2 | ##' The `odin_parse_` version is a "standard evaluation" escape 3 | ##' hatch. 4 | ##' 5 | ##' A schema for the intermediate representation is available in the 6 | ##' package as `schema.json`. It is subject to change at this 7 | ##' point. 8 | ##' 9 | ##' @title Parse an odin model 10 | ##' 11 | ##' @param x An expression, character vector or filename with the odin 12 | ##' code 13 | ##' 14 | ##' @param options odin options; see [odin::odin_options]. The 15 | ##' primary options that affect the parse stage are `validate` 16 | ##' and `pretty`. 17 | ##' 18 | ##' @param type An optional string indicating the the type of input - 19 | ##' must be one of `expression`, `file` or `text` if 20 | ##' provided. This skips the type detection code used by odin and 21 | ##' makes validating user input easier. 22 | ##' 23 | ##' @export 24 | ##' 25 | ##' @seealso [odin::odin_validate], which wraps this function 26 | ##' where parsing might fail, and [odin::odin_build] for 27 | ##' building odin models from an intermediate representation. 28 | ##' 29 | ##' @examples 30 | ##' # Parse a model of exponential decay 31 | ##' ir <- odin::odin_parse({ 32 | ##' deriv(y) <- -0.5 * y 33 | ##' initial(y) <- 1 34 | ##' }) 35 | ##' 36 | ##' # This is odin's intermediate representation of the model 37 | ##' ir 38 | ##' 39 | ##' # If parsing odin models programmatically, it is better to use 40 | ##' # odin_parse_; construct the model as a string, from a file, or as a 41 | ##' # quoted expression: 42 | ##' code <- quote({ 43 | ##' deriv(y) <- -0.5 * y 44 | ##' initial(y) <- 1 45 | ##' }) 46 | ##' 47 | ##' odin::odin_parse_(code) 48 | odin_parse <- function(x, type = NULL, options = NULL) { 49 | xx <- substitute(x) 50 | if (is.symbol(xx)) { 51 | xx <- force(x) 52 | } else if (is_call(xx, quote(c)) && all(vlapply(xx[-1], is.character))) { 53 | ## See #88 54 | xx <- force(x) 55 | } 56 | odin_parse_(xx, options) 57 | } 58 | 59 | 60 | ##' @export 61 | ##' @rdname odin_parse 62 | odin_parse_ <- function(x, options = NULL, type = NULL) { 63 | options <- odin_options(options = options) 64 | assert_scalar_character_or_null(type) 65 | ir_parse(x, options, type) 66 | } 67 | -------------------------------------------------------------------------------- /R/misc.R: -------------------------------------------------------------------------------- 1 | ## Things that should end up elsewhere eventually 2 | 3 | join_library <- function(x) { 4 | list(declarations = unlist(lapply(x, "[[", "declarations")), 5 | definitions = unlist(lapply(x, "[[", "definitions")), 6 | filename = unlist(lapply(x, "[[", "filename"))) 7 | } 8 | 9 | 10 | combine_include <- function(x) { 11 | declarations <- unlist(lapply(x, "[[", "declarations"), FALSE) 12 | definitions <- unlist(lapply(x, "[[", "definitions"), FALSE) 13 | 14 | check <- function(x) { 15 | dups <- unique(names(x)[duplicated(names(x))]) 16 | for (nm in dups) { 17 | if (length(unique(x[names(x) == nm])) > 1) { 18 | stop(sprintf( 19 | "Duplicated entries in included C support not allowed (check '%s')", 20 | nm)) 21 | } 22 | } 23 | unique(x) 24 | } 25 | 26 | list(declarations = check(declarations), 27 | definitions = check(definitions)) 28 | } 29 | 30 | 31 | read_user_c <- function(filename) { 32 | read_include_c(filename)$data 33 | } 34 | 35 | 36 | read_include_c <- function(filename) { 37 | d <- readLines(filename) 38 | 39 | re1 <- "^[[:alnum:]_*]+ ([[:alnum:]_]+)(.+)" 40 | i1 <- grep(re1, d) 41 | i2 <- grep("^}$", d) 42 | if (length(i1) != length(i2)) { 43 | stop("Parse error for ", filename) 44 | } 45 | name <- sub(re1, "\\1", d[i1]) 46 | defn <- setNames(vcapply(seq_along(i1), function(k) { 47 | paste(d[i1[[k]]:i2[[k]]], collapse = "\n") 48 | }), name) 49 | decl <- sub("^([^{]*?)\\s*\\{.*", "\\1;", defn) 50 | 51 | list( 52 | names = name, 53 | data = list(names = name, 54 | declarations = decl, 55 | definitions = defn, 56 | filename = filename)) 57 | } 58 | 59 | 60 | read_include_r <- function(filename) { 61 | e <- new.env(parent = baseenv()) 62 | sys.source(filename, e) 63 | list(names = names(e), 64 | data = list(source = readLines(filename))) 65 | } 66 | 67 | 68 | read_include_unsupported <- function(target) { 69 | force(target) 70 | function(filename) { 71 | stop(sprintf("'config(include)' is not supported for target '%s'", target)) 72 | } 73 | } 74 | 75 | 76 | is_c_identifier <- function(x) { 77 | grepl("^[A-Za-z_][A-Za-z0-9_]*$", x) & !(x %in% RESERVED_C) 78 | } 79 | 80 | 81 | is_dim_or_length <- function(x) { 82 | is_call(x, quote(dim)) || is_call(x, quote(length)) 83 | } 84 | -------------------------------------------------------------------------------- /R/debug.R: -------------------------------------------------------------------------------- 1 | ## Handle parsing of a print string, via glue 2 | debug_parse_string <- function(string) { 3 | seen <- collector() 4 | transformer <- function(text, envir) { 5 | seen$add(trimws(text)) 6 | text 7 | } 8 | glue::glue(string, .transformer = transformer) 9 | seen$get() 10 | } 11 | 12 | 13 | debug_substitute_string <- function(string, values) { 14 | seen <- collector() 15 | transformer <- function(text, envir) { 16 | seen$add(text) 17 | values[[seen$length()]] 18 | } 19 | glue::glue(string, .transformer = transformer) 20 | } 21 | 22 | 23 | debug_parse_element <- function(str) { 24 | re <- "(.+)\\s*;\\s*(.+)" 25 | has_format <- grepl(re, str) 26 | if (has_format) { 27 | format <- sub(re, "\\2", str) 28 | ## Try applying the format in; we'll error here and be caught 29 | ## later if this is not interpretable. 30 | sprintf(paste0("%", format), 1) 31 | value <- sub(re, "\\1", str) 32 | } else { 33 | format <- NULL 34 | value <- str 35 | } 36 | 37 | expr <- parse(text = value)[[1]] 38 | depends <- find_symbols(expr) 39 | 40 | list(expr = expr, depends = depends, format = format) 41 | } 42 | 43 | 44 | ## This is a bit tedious, we could work with match.call but it's a 45 | ## bit too magic. 46 | debug_parse_print_call <- function(args, line, source) { 47 | if (length(args) == 0) { 48 | ir_parse_error("print() expects at least one argument", line, source) 49 | } 50 | if (!is.null(names(args)) && nzchar(names(args)[[1]])) { 51 | ir_parse_error("print() expects the first argument to be unnamed", 52 | line, source) 53 | } 54 | 55 | expr <- args[[1]] 56 | args <- as.list(args[-1]) 57 | 58 | if (!is.character(expr)) { 59 | ir_parse_error("print() requires a string argument", line, source) 60 | } 61 | 62 | if (length(args) > 0 && (is.null(names(args)) || any(!nzchar(names(args))))) { 63 | ir_parse_error("print() expects every argument but the first to be named", 64 | line, source) 65 | } 66 | 67 | args_allowed <- "when" 68 | err <- setdiff(names(args), args_allowed) 69 | if (length(err) > 0) { 70 | ir_parse_error(sprintf("Unknown argument to print(): %s", 71 | paste(squote(err), collapse = ", ")), 72 | line, source) 73 | } 74 | 75 | list(type = "print", 76 | expr = expr, 77 | when = args$when) 78 | } 79 | -------------------------------------------------------------------------------- /man/odin_validate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/odin_validate.R 3 | \name{odin_validate} 4 | \alias{odin_validate} 5 | \title{Validate an odin model} 6 | \usage{ 7 | odin_validate(x, type = NULL, options = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{An expression, character vector or filename with the odin 11 | code} 12 | 13 | \item{type}{An optional string indicating the the type of input - 14 | must be one of \code{expression}, \code{file} or \code{text} if 15 | provided. This skips the type detection code used by odin and 16 | makes validating user input easier.} 17 | 18 | \item{options}{odin options; see \link{odin_options}. The 19 | primary options that affect the parse stage are \code{validate} 20 | and \code{pretty}.} 21 | } 22 | \description{ 23 | Validate an odin model. This function is closer to 24 | \link{odin_parse_} than \link{odin_parse} because it 25 | does not do any quoting of the code. It is primarily intended for 26 | use within other applications. 27 | } 28 | \details{ 29 | \code{odin_validate} will always return a list with the same 30 | elements: 31 | 32 | \describe{ 33 | \item{success}{A boolean, \code{TRUE} if validation was successful} 34 | 35 | \item{result}{The intermediate representation, as returned by 36 | \link{odin_parse_}, if the validation was successful, 37 | otherwise \code{NULL}} 38 | 39 | \item{error}{An error object if the validation was unsuccessful, 40 | otherwise \code{NULL}. This may be a classed odin error, in which 41 | case it will contain source location information - see the 42 | examples for details.} 43 | 44 | \item{messages}{A list of messages, if the validation returned 45 | any. At present this is only non-fatal information about unused 46 | variables.} 47 | } 48 | } 49 | \examples{ 50 | 51 | # A successful validation: 52 | odin::odin_validate(c("deriv(x) <- 1", "initial(x) <- 1")) 53 | 54 | # A complete failure: 55 | odin::odin_validate("") 56 | 57 | # A more interesting failure 58 | code <- c("deriv(x) <- a", "initial(x) <- 1") 59 | res <- odin::odin_validate(code) 60 | res 61 | 62 | # The object 'res$error' is an 'odin_error' object: 63 | res$error 64 | 65 | # It contains information that might be used to display to a 66 | # user information about the error: 67 | unclass(res$error) 68 | 69 | # Notes are raised in a similar way: 70 | code <- c("deriv(x) <- 1", "initial(x) <- 1", "a <- 1") 71 | res <- odin::odin_validate(code) 72 | res$messages[[1]] 73 | } 74 | \author{ 75 | Rich FitzJohn 76 | } 77 | -------------------------------------------------------------------------------- /R/ir_deserialise.R: -------------------------------------------------------------------------------- 1 | ##' Deserialise odin's intermediate model representation from a json 2 | ##' string into an R object. Unlike the json, there is no schema for 3 | ##' this representation. This function provides access to the same 4 | ##' deserialisation that odin uses internally so may be useful in 5 | ##' applications. 6 | ##' 7 | ##' @title Deserialise odin's IR 8 | ##' @param x An intermediate representation as a json string 9 | ##' @return A named list 10 | ##' @seealso [odin::odin_parse] 11 | ##' @export 12 | ##' @examples 13 | ##' # Parse a model of exponential decay 14 | ##' ir <- odin::odin_parse({ 15 | ##' deriv(y) <- -0.5 * y 16 | ##' initial(y) <- 1 17 | ##' }) 18 | ##' # Convert the representation to an R object 19 | ##' odin::odin_ir_deserialise(ir) 20 | odin_ir_deserialise <- function(x) { 21 | if (!inherits(x, "json")) { 22 | stop("Expected a json string") 23 | } 24 | ir_deserialise(x) 25 | } 26 | 27 | 28 | ir_deserialise <- function(ir) { 29 | dat <- from_json(ir) 30 | dat$version <- numeric_version(dat$version) 31 | dat$components <- lapply(dat$components, lapply, list_to_character) 32 | 33 | names(dat$data$elements) <- vcapply(dat$data$elements, "[[", "name") 34 | names(dat$data$variable$contents) <- 35 | vcapply(dat$data$variable$contents, "[[", "name") 36 | names(dat$data$output$contents) <- 37 | vcapply(dat$data$output$contents, "[[", "name") 38 | names(dat$equations) <- vcapply(dat$equations, "[[", "name") 39 | names(dat$user) <- vcapply(dat$user, "[[", "name") 40 | 41 | dat$interpolate <- lapply(dat$interpolate, list_to_character) 42 | dat$equations <- lapply(dat$equations, ir_deserialise_equation) 43 | dat$debug <- lapply(dat$debug, ir_deserialise_debug) 44 | dat$ir <- ir 45 | 46 | dat 47 | } 48 | 49 | 50 | ir_deserialise_equation <- function(eq) { 51 | if (!is.null(eq$depends)) { 52 | eq$depends <- lapply(eq$depends, list_to_character) 53 | } 54 | if (eq$type == "delay_continuous") { 55 | eq$delay$equations <- list_to_character(eq$delay$equations) 56 | names(eq$delay$variables$contents) <- 57 | vcapply(eq$delay$variables$contents, "[[", "name") 58 | eq$delay$substitutions <- 59 | set_names( 60 | vcapply(eq$delay$substitutions, "[[", "to"), 61 | vcapply(eq$delay$substitutions, "[[", "from")) 62 | } 63 | eq 64 | } 65 | 66 | 67 | ir_deserialise_debug <- function(eq) { 68 | if (!is.null(eq$depends)) { 69 | eq$depends <- lapply(eq$depends, list_to_character) 70 | } 71 | eq 72 | } 73 | -------------------------------------------------------------------------------- /R/generate_js_util.R: -------------------------------------------------------------------------------- 1 | js_flatten_eqs <- function(eqs) { 2 | unlist(unname(eqs)) 3 | } 4 | 5 | 6 | js_function <- function(args, body, name = NULL) { 7 | if (is.null(name)) { 8 | start <- sprintf("function(%s) {", paste(args, collapse = ", ")) 9 | } else if (name == "constructor") { 10 | start <- sprintf("constructor(%s) {", paste(args, collapse = ", ")) 11 | } else { 12 | start <- sprintf("function %s(%s) {", name, paste(args, collapse = ", ")) 13 | } 14 | if (length(body) > 0L) { 15 | body <- paste0(" ", body) 16 | } 17 | c(start, body, "}") 18 | } 19 | 20 | js_dict <- function(x) { 21 | sprintf("{%s}", paste(sprintf("%s: %s", names(x), x), collapse = ", ")) 22 | } 23 | 24 | js_extract_variable <- function(x, data_elements, state, rewrite) { 25 | d <- data_elements[[x$name]] 26 | if (d$rank == 0L) { 27 | sprintf("%s[%s]", state, rewrite(x$offset)) 28 | } else { 29 | offset <- rewrite(x$offset) 30 | len <- rewrite(d$dimnames$length) 31 | sprintf("%s.slice(%s, %s + %s)", state, offset, offset, len) 32 | } 33 | } 34 | 35 | 36 | js_unpack_variable <- function(name, dat, state, rewrite) { 37 | x <- dat$data$variable$contents[[name]] 38 | rhs <- js_extract_variable(x, dat$data$elements, state, rewrite) 39 | sprintf("const %s = %s;", x$name, rhs) 40 | } 41 | 42 | 43 | js_unpack_variable_delay <- function(x, data_elements, state, rewrite) { 44 | rhs <- js_extract_variable(x, data_elements, state, rewrite) 45 | sprintf("const %s = %s;", x$name, rhs) 46 | } 47 | 48 | 49 | js_array_access <- function(target, index, data, meta) { 50 | mult <- data$elements[[target]]$dimnames$mult 51 | 52 | f <- function(i) { 53 | index_i <- js_minus_1(index[[i]], i > 1, data, meta) 54 | if (i == 1) { 55 | index_i 56 | } else { 57 | mult_i <- generate_js_sexp(mult[[i]], data, meta) 58 | sprintf("%s * %s", mult_i, index_i) 59 | } 60 | } 61 | 62 | paste(vcapply(rev(seq_along(index)), f), collapse = " + ") 63 | } 64 | 65 | 66 | js_minus_1 <- function(x, protect, data, meta) { 67 | if (is.numeric(x)) { 68 | generate_js_sexp(x - 1L, data, meta) 69 | } else { 70 | x_expr <- generate_js_sexp(x, data, meta) 71 | sprintf(if (protect) "(%s - 1)" else "%s - 1", x_expr) 72 | } 73 | } 74 | 75 | 76 | js_fold_call <- function(fn, args) { 77 | if (length(args) == 1L) { 78 | args[[1L]] 79 | } else { 80 | sprintf("%s(%s, %s)", fn, args[[1L]], js_fold_call(fn, args[-1])) 81 | } 82 | } 83 | 84 | js_expr_if <- function(condition, a, b) { 85 | c(sprintf_safe("if (%s) {", condition), 86 | paste0(" ", js_flatten_eqs(a)), 87 | "} else {", 88 | paste0(" ", js_flatten_eqs(b)), 89 | "}") 90 | } 91 | -------------------------------------------------------------------------------- /R/odin_validate.R: -------------------------------------------------------------------------------- 1 | ##' Validate an odin model. This function is closer to 2 | ##' [odin::odin_parse_] than [odin::odin_parse] because it 3 | ##' does not do any quoting of the code. It is primarily intended for 4 | ##' use within other applications. 5 | ##' 6 | ##' `odin_validate` will always return a list with the same 7 | ##' elements: 8 | ##' 9 | ##' \describe{ 10 | ##' \item{success}{A boolean, `TRUE` if validation was successful} 11 | ##' 12 | ##' \item{result}{The intermediate representation, as returned by 13 | ##' [odin::odin_parse_], if the validation was successful, 14 | ##' otherwise `NULL`} 15 | ##' 16 | ##' \item{error}{An error object if the validation was unsuccessful, 17 | ##' otherwise `NULL`. This may be a classed odin error, in which 18 | ##' case it will contain source location information - see the 19 | ##' examples for details.} 20 | ##' 21 | ##' \item{messages}{A list of messages, if the validation returned 22 | ##' any. At present this is only non-fatal information about unused 23 | ##' variables.} 24 | ##' } 25 | ##' 26 | ##' @title Validate an odin model 27 | ##' 28 | ##' @inheritParams odin_parse 29 | ##' 30 | ##' @export 31 | ##' @author Rich FitzJohn 32 | ##' @examples 33 | ##' 34 | ##' # A successful validation: 35 | ##' odin::odin_validate(c("deriv(x) <- 1", "initial(x) <- 1")) 36 | ##' 37 | ##' # A complete failure: 38 | ##' odin::odin_validate("") 39 | ##' 40 | ##' # A more interesting failure 41 | ##' code <- c("deriv(x) <- a", "initial(x) <- 1") 42 | ##' res <- odin::odin_validate(code) 43 | ##' res 44 | ##' 45 | ##' # The object 'res$error' is an 'odin_error' object: 46 | ##' res$error 47 | ##' 48 | ##' # It contains information that might be used to display to a 49 | ##' # user information about the error: 50 | ##' unclass(res$error) 51 | ##' 52 | ##' # Notes are raised in a similar way: 53 | ##' code <- c("deriv(x) <- 1", "initial(x) <- 1", "a <- 1") 54 | ##' res <- odin::odin_validate(code) 55 | ##' res$messages[[1]] 56 | odin_validate <- function(x, type = NULL, options = NULL) { 57 | msg <- collector_list() 58 | .odin$note_function <- msg$add 59 | on.exit(.odin$note_function <- NULL) 60 | 61 | ## NOTE: this does not involve the cache at all, though it possibly 62 | ## should. If we do involve the cache we'll need to come up with 63 | ## something that can be purged or we'll have memory grow without 64 | ## bounds. 65 | res <- tryCatch( 66 | odin_parse_(x, type = type, options = options), 67 | error = identity) 68 | 69 | success <- !inherits(res, "error") 70 | error <- if (success) NULL else res 71 | result <- if (success) res else NULL 72 | 73 | list(success = success, 74 | result = result, 75 | error = error, 76 | messages = msg$get()) 77 | } 78 | -------------------------------------------------------------------------------- /R/odin_preprocess.R: -------------------------------------------------------------------------------- 1 | odin_preprocess <- function(x, type = NULL) { 2 | preprocess_expression <- function(x) { 3 | if (inherits(x, "{")) { 4 | as.expression(as.list(x[-1L])) 5 | } else { 6 | as.expression(x) 7 | } 8 | } 9 | 10 | type <- odin_preprocess_detect(x, type) 11 | 12 | exprs <- switch(type, 13 | file = parse(file = x, keep.source = TRUE), 14 | text = parse(text = x, keep.source = TRUE), 15 | expression = preprocess_expression(x)) 16 | 17 | if (type == "file") { 18 | file <- x 19 | root <- normalizePath(dirname(x)) 20 | path <- c(root, normalizePath(getwd())) 21 | base <- tools::file_path_sans_ext(basename(file)) 22 | ## Most of the time we get parentheses it will be download errors 23 | base <- gsub("\\s*\\(\\d+\\)", "", base) 24 | ## But if we do get them after that we should remove them, along 25 | ## with any other punctuation 26 | base <- gsub("[-.() ]", "_", base) 27 | base <- gsub("_$", "", gsub("_{2,}", "_", base)) 28 | } else { 29 | file <- NULL 30 | path <- getwd() 31 | root <- getwd() 32 | base <- "odin" 33 | } 34 | 35 | ret <- list(type = type, 36 | path = path, 37 | root = root, 38 | file = file, 39 | base = base, 40 | exprs = exprs) 41 | 42 | ## TODO: This is a bit of a hack to avoid rewriting all the uses of 43 | ## odin_parse in the tests. They could be rewritten using a fn 44 | ## > odin_parse2 <- function(x) odin_parse(odin_preprocess(x)) 45 | ## perhaps? 46 | attr(ret, "odin_preprocessed") <- TRUE 47 | ret 48 | } 49 | 50 | odin_preprocess_detect <- function(x, type = NULL) { 51 | has_type <- !is.null(type) 52 | if (has_type) { 53 | type <- match_value(type, c("file", "text", "expression")) 54 | } 55 | 56 | if (is.language(x)) { 57 | if (has_type && type != "expression") { 58 | stop(sprintf("Invalid input for odin - expected %s", type), 59 | call. = FALSE) 60 | } 61 | as <- "expression" 62 | } else if (is.character(x)) { 63 | if (has_type) { 64 | if (type == "expression") { 65 | stop("Invalid input for odin - expected expression", call. = FALSE) 66 | } else if (type == "file") { 67 | stopifnot(length(x) == 1, is.character(x), !is.na(x)) 68 | if (!file.exists(x)) { 69 | stop(sprintf("File '%s' does not exist", x), call. = FALSE) 70 | } 71 | } 72 | as <- type 73 | } else if (length(x) != 1L || grepl("([\n;=]|<-)", x)) { 74 | as <- "text" 75 | } else if (file.exists(x)) { 76 | as <- "file" 77 | } else { 78 | stop(sprintf("'%s' looks like a filename, but file does not exist", x)) 79 | } 80 | } else { 81 | stop("Invalid type for 'x'") 82 | } 83 | as 84 | } 85 | -------------------------------------------------------------------------------- /tests/testthat/test-parse-inplace.R: -------------------------------------------------------------------------------- 1 | context("parse: inplace") 2 | 3 | test_that("can't use integer inplace for update()", { 4 | expect_error(odin_parse({ 5 | q[] <- user() 6 | p[] <- q[i] / sum(q) 7 | initial(x[]) <- 0 8 | update(x[]) <- rmultinom(5, p) 9 | dim(p) <- 5 10 | dim(q) <- 5 11 | dim(x) <- 5 12 | }), 13 | "Can't use inplace integer expression in update", 14 | class = "odin_error") 15 | }) 16 | 17 | 18 | test_that("can't use multiline inplace", { 19 | expect_error(odin_parse({ 20 | q[] <- user() 21 | p[] <- q[i] / sum(q) 22 | initial(x[]) <- 0 23 | update(x[]) <- y[i] 24 | y[] <- rmultinom(5, p) 25 | y[1] <- 0 26 | dim(p) <- 5 27 | dim(q) <- 5 28 | dim(x) <- 5 29 | dim(y) <- 5 30 | }), 31 | "in-place equations may only be used on a single-line array", 32 | class = "odin_error") 33 | }) 34 | 35 | 36 | test_that("rmultinom is integer", { 37 | ir <- odin_parse({ 38 | q[] <- user() 39 | p[] <- q[i] / sum(q) 40 | initial(x[]) <- 0 41 | update(x[]) <- y[i] 42 | y[] <- rmultinom(5, p) 43 | dim(p) <- 5 44 | dim(q) <- 5 45 | dim(x) <- 5 46 | dim(y) <- 5 47 | }) 48 | dat <- ir_deserialise(ir) 49 | expect_equal(dat$data$elements$y$storage_type, "int") 50 | expect_equal(dat$data$elements$y$rank, 1) 51 | }) 52 | 53 | 54 | test_that("rmhyper is integer", { 55 | ir <- odin_parse({ 56 | x0[] <- user() 57 | dim(x0) <- user() 58 | n <- user() 59 | nk <- length(x0) 60 | tmp[] <- rmhyper(n, x0) 61 | dim(tmp) <- nk 62 | initial(x[]) <- 0 63 | update(x[]) <- tmp[i] 64 | dim(x) <- nk 65 | }) 66 | dat <- ir_deserialise(ir) 67 | expect_equal(dat$data$elements$tmp$storage_type, "int") 68 | expect_equal(dat$data$elements$tmp$rank, 1) 69 | }) 70 | 71 | 72 | test_that("rmultinom argument validation", { 73 | expect_error(odin_parse({ 74 | update(x) <- 1 75 | initial(x) <- 1 76 | p[] <- 0.2 77 | dim(p) <- 5 78 | dim(y) <- 5 79 | y[] <- rmultinom(p, 5) 80 | }), 81 | "Function 'rmultinom' requires array as argument 2", 82 | class = "odin_error") 83 | }) 84 | 85 | 86 | test_that("in place expressions must be simple", { 87 | expect_error( 88 | odin_parse({ 89 | update(x) <- 1 90 | initial(x) <- 1 91 | y <- rmultinom(5 + 2, x) 92 | }), 93 | "At present, inplace function 'rmultinom' must use no functions", 94 | class = "odin_error") 95 | }) 96 | 97 | 98 | test_that("in place expressions must return an array", { 99 | expect_error( 100 | odin_parse({ 101 | update(x) <- 1 102 | initial(x) <- 1 103 | y <- rmultinom(2, x) 104 | }), 105 | "Expected an array on the lhs of inplace function 'rmultinom'", 106 | class = "odin_error") 107 | }) 108 | -------------------------------------------------------------------------------- /tests/testthat/examples/seir_array_deSolve.R: -------------------------------------------------------------------------------- 1 | seir_array <- function() { 2 | b <- 1 / (365 * 50) 3 | N <- 1e7 4 | beta <- 1 5 | sigma <- 1 / 30 6 | delta <- 1 / 60 7 | lat_hum <- 14 8 | I0 <- 1 9 | 10 | N_age <- 5L 11 | age_width <- c(1, 4, 10, 15, 20) * 365 12 | age_rate <- c(1 / age_width[-N_age], 0.0) 13 | den <- numeric(N_age) 14 | den[[1L]] <- 1.0 / (1.0 + age_rate[[1L]] / b) 15 | for (i in 2:N_age) { 16 | den[i] <- age_rate[[i - 1L]] * den[[i - 1L]] / (age_rate[i] + b) 17 | } 18 | rm(i) 19 | 20 | Births <- N * b 21 | ## i.e. proportion of humans surviving the latent period 22 | surv <- exp(-b * lat_hum) 23 | 24 | t0 <- NULL 25 | y0 <- NULL 26 | lag <- NULL 27 | 28 | i_S <- 1:N_age 29 | i_I <- 1:N_age + (2 * N_age) 30 | 31 | initial <- function(t = 0, pars = NULL) { 32 | if ("I0" %in% names(pars)) { 33 | I0 <<- pars$I0 34 | } 35 | t0 <<- t 36 | y0 <<- c(den * (N - I0), # S 37 | den * 0, # E 38 | den * I0, # I 39 | den * 0) # R 40 | lag <<- make_lagvalue(t0, y0) 41 | y0 42 | } 43 | 44 | derivs <- function(t, y, .) { 45 | y <- matrix(y, N_age, 4L) 46 | 47 | S <- y[, 1L] 48 | E <- y[, 2L] 49 | I <- y[, 3L] 50 | R <- y[, 4L] 51 | dSdt <- numeric(N_age) 52 | dEdt <- numeric(N_age) 53 | dIdt <- numeric(N_age) 54 | dRdt <- numeric(N_age) 55 | 56 | I_tot <- sum(I) 57 | 58 | ## people developing latent infection 59 | new_inf <- beta * S * I_tot / N 60 | 61 | ## people that become latent 'lat_hum' days ago, less those that 62 | ## died during that time 63 | S_lag <- lag(t, lat_hum, i_S) 64 | I_lag <- lag(t, lat_hum, i_I) 65 | I_lag_tot <- sum(I_lag) 66 | lag_inf <- (beta * S_lag * I_lag_tot / N) * surv 67 | 68 | dSdt[[1]] <- - new_inf[[1L]] + delta * R[[1L]] - b * S[[1L]] + 69 | (Births - age_rate[[1L]] * S[[1L]]) 70 | dSdt[-1] <- - new_inf[-1L] + delta * R[-1L] - b * S[-1L] + 71 | (age_rate[-N_age] * S[-N_age] - age_rate[-1L] * S[-1L]) 72 | 73 | dEdt[[1L]] <- new_inf[[1L]] - lag_inf[[1L]] - b * E[[1L]] + 74 | (-age_rate[[1L]] * E[[1L]]) 75 | dEdt[-1L] <- new_inf[-1L] - lag_inf[-1L] - b * E[-1L] + 76 | (age_rate[-N_age] * E[-N_age] - age_rate[-1L] * E[-1L]) 77 | 78 | dIdt[[1L]] <- lag_inf[[1L]] - (b + sigma) * I[[1L]] + 79 | (- age_rate[[1L]] * I[[1L]]) 80 | dIdt[-1L] <- lag_inf[-1L] - (b + sigma) * I[-1L] + 81 | (age_rate[-N_age] * I[-N_age] - age_rate[-1L] * I[-1L]) 82 | 83 | dRdt[[1L]] <- sigma * I[[1L]] - b * R[[1L]] - delta * R[[1L]] + 84 | (- age_rate[[1L]] * R[[1L]]) 85 | dRdt[-1L] <- sigma * I[-1L] - b * R[-1L] - delta * R[-1L] + 86 | (age_rate[-N_age] * R[-N_age] - age_rate[-1L] * R[-1L]) 87 | 88 | list(c(dSdt, dEdt, dIdt, dRdt)) 89 | } 90 | 91 | list(initial = initial, derivs = derivs, delay = TRUE, t = c(0, 365)) 92 | } 93 | -------------------------------------------------------------------------------- /R/odin_build.R: -------------------------------------------------------------------------------- 1 | ##' Build an odin model generator from its intermediate 2 | ##' representation, as generated by [odin::odin_parse]. This 3 | ##' function is for advanced use. 4 | ##' 5 | ##' In applications that want to inspect the intermediate 6 | ##' representation rather before compiling, rather than directly using 7 | ##' [odin::odin], use either [odin::odin_parse] or 8 | ##' [odin::odin_validate] and then pass the result to 9 | ##' `odin::odin_build`. 10 | ##' 11 | ##' The return value of this function includes information about how 12 | ##' long the compilation took, if it was successful, etc, in the same 13 | ##' style as [odin::odin_validate]: 14 | ##' 15 | ##' \describe{ 16 | ##' \item{success}{Logical, indicating if compilation was successful} 17 | ##' 18 | ##' \item{elapsed}{Time taken to compile the model, as a 19 | ##' `proc_time` object, as returned by [proc.time].} 20 | ##' 21 | ##' \item{output}{Any output produced when compiling the model (only 22 | ##' present if compiling to C, and if the cache was not hit.} 23 | ##' 24 | ##' \item{model}{The model itself, as an `odin_generator` object, 25 | ##' as returned by [odin::odin].} 26 | ##' 27 | ##' \item{ir}{The intermediate representation.} 28 | ##' 29 | ##' \item{error}{Any error thrown during compilation} 30 | ##' } 31 | ##' 32 | ##' @title Build an odin model generator from its IR 33 | ##' 34 | ##' @param x An odin ir (json) object or output from 35 | ##' [odin::odin_validate]. 36 | ##' 37 | ##' @param options Options to pass to the build stage (see 38 | ##' [odin::odin_options] 39 | ##' 40 | ##' @export 41 | ##' 42 | ##' @seealso [odin::odin_parse], which creates intermediate 43 | ##' representations used by this function. 44 | ##' 45 | ##' @examples 46 | ##' # Parse a model of exponential decay 47 | ##' ir <- odin::odin_parse({ 48 | ##' deriv(y) <- -0.5 * y 49 | ##' initial(y) <- 1 50 | ##' }) 51 | ##' 52 | ##' # Compile the model: 53 | ##' options <- odin::odin_options(target = "r") 54 | ##' res <- odin::odin_build(ir, options) 55 | ##' 56 | ##' # All results: 57 | ##' res 58 | ##' 59 | ##' # The model: 60 | ##' mod <- res$model$new() 61 | ##' mod$run(0:10) 62 | odin_build <- function(x, options = NULL) { 63 | options <- odin_options(options = options) 64 | 65 | if (is.list(x) && inherits(x$result, "json")) { 66 | x <- x$result 67 | } else if (!inherits(x, "json")) { 68 | stop("Expected an odin intermediate representation") 69 | } 70 | 71 | elapsed <- system.time( 72 | output <- utils::capture.output( 73 | suppressMessages( 74 | model <- tryCatch( 75 | odin_generate(x, options), 76 | error = identity))), 77 | gcFirst = FALSE) 78 | 79 | is_error <- inherits(model, "error") 80 | 81 | if (is_error) { 82 | error <- model$message 83 | model <- NULL 84 | } else { 85 | error <- NULL 86 | } 87 | 88 | list( 89 | success = !is_error, 90 | elapsed = elapsed, 91 | output = output, 92 | model = model, 93 | ir = x, 94 | error = error) 95 | } 96 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-delay.R: -------------------------------------------------------------------------------- 1 | context("parse: delay") 2 | 3 | test_that("missing variables in delay", { 4 | expect_error(odin_parse({ 5 | ylag <- delay(x, 10) 6 | initial(y) <- 0.5 7 | deriv(y) <- y + ylag 8 | }), "Missing variable in delay expression", class = "odin_error") 9 | 10 | expect_error(odin_parse({ 11 | ylag <- delay(x + y, 10) 12 | initial(y) <- 0.5 13 | deriv(y) <- y + ylag 14 | }), "Missing variable in delay expression", class = "odin_error") 15 | 16 | expect_error(odin_parse({ 17 | ylag <- delay(x + z, 10) 18 | initial(y) <- 0.5 19 | deriv(y) <- y + ylag 20 | }), "Missing variables in delay expression", class = "odin_error") 21 | }) 22 | 23 | 24 | test_that("delay call validation", { 25 | expect_error(odin_parse_(quote(a <- 1 + delay(1))), 26 | "delay() must be the only call on the rhs", 27 | fixed = TRUE, class = "odin_error") 28 | expect_error(odin_parse_(quote(a <- delay(1))), 29 | "delay() requires two or three arguments", 30 | fixed = TRUE, class = "odin_error") 31 | expect_error(odin_parse_(quote(a <- delay(1, 2, 3, 4))), 32 | "delay() requires two or three arguments", 33 | fixed = TRUE, class = "odin_error") 34 | expect_error(odin_parse_(quote(a <- delay(delay(1, 2), 2))), 35 | "delay() may not be nested", 36 | fixed = TRUE, class = "odin_error") 37 | expect_error(odin_parse_(quote(a <- delay(2, delay(1, 2)))), 38 | "delay() may not be nested", 39 | fixed = TRUE, class = "odin_error") 40 | 41 | expect_error(odin_parse_(quote(a <- delay(y + t, 2))), 42 | "delay() may not refer to time", 43 | fixed = TRUE, class = "odin_error") 44 | }) 45 | 46 | 47 | test_that("delay check", { 48 | expect_error(ir_parse_expr(quote(deriv(x) <- delay(y, 1)), NULL, NULL), 49 | "delay() only valid for non-special variables", 50 | fixed = TRUE, class = "odin_error") 51 | expect_error(ir_parse_expr(quote(initial(x) <- delay(y, 1)), NULL, NULL), 52 | "delay() only valid for non-special variables", 53 | fixed = TRUE, class = "odin_error") 54 | expect_error(ir_parse_expr(quote(dim(x) <- delay(y, 1)), NULL, NULL), 55 | "delay() only valid for non-special variables", 56 | fixed = TRUE, class = "odin_error") 57 | }) 58 | 59 | 60 | test_that("more parse errors", { 61 | expect_error(odin_parse({ 62 | x <- y + b 63 | ylag <- delay(x, 10) 64 | initial(y) <- 0.5 65 | deriv(y) <- y + ylag 66 | }), "Missing variable in delay expression: b (for delay ylag)", 67 | fixed = TRUE, class = "odin_error") 68 | }) 69 | 70 | 71 | test_that("prevent multiline delay", { 72 | expect_error( 73 | odin_parse({ 74 | deriv(a[]) <- i 75 | initial(a[]) <- (i - 1) / 10 76 | dim(a) <- 5 77 | alt[] <- user() 78 | dim(alt) <- length(a) 79 | tmp[1] <- delay(a[1], 2, alt[1]) 80 | tmp[2:5] <- delay(a[i], 2, alt[i]) 81 | dim(tmp) <- length(a) 82 | output(tmp[]) <- TRUE # or tmp[i] 83 | }), 84 | "delay() may only be used on a single-line array", 85 | fixed = TRUE, class = "odin_error") 86 | }) 87 | -------------------------------------------------------------------------------- /R/generate_c.R: -------------------------------------------------------------------------------- 1 | generate_c_meta <- function(base, internal) { 2 | list( 3 | ptr = sprintf("%s_p", internal), 4 | internal_ds = sprintf("%s_%s_ds", base, internal), 5 | internal_t = sprintf("%s_internal", base), 6 | finalise = sprintf("%s_finalise", base), 7 | create = sprintf("%s_create", base), 8 | contents = sprintf("%s_contents", base), 9 | get_internal = sprintf("%s_get_internal", base), 10 | set_user = sprintf("%s_set_user", base), 11 | set_initial = sprintf("%s_set_initial", base), 12 | use_dde = sprintf("%s_use_dde", base), 13 | initial_conditions = sprintf("%s_initial_conditions", base), 14 | metadata = sprintf("%s_metadata", base), 15 | rhs = sprintf("%s_rhs", base), 16 | rhs_desolve = sprintf("%s_rhs_desolve", base), 17 | rhs_dde = sprintf("%s_rhs_dde", base), 18 | rhs_r = sprintf("%s_rhs_r", base), 19 | output_dde = sprintf("%s_output_dde", base), 20 | initmod_desolve = sprintf("%s_initmod_desolve", base)) 21 | } 22 | 23 | 24 | generate_c_code <- function(dat, options, package) { 25 | dat$options <- options 26 | dat$meta$c <- generate_c_meta(dat$config$base, dat$meta$internal) 27 | 28 | if (dat$features$mixed) { 29 | stop("Models that mix deriv() and update() are not supported") 30 | } 31 | if (dat$features$has_compare || dat$features$has_data) { 32 | stop("data() and compare() not supported") 33 | } 34 | 35 | if (dat$features$has_delay) { 36 | dat$data$elements[[dat$meta$c$use_dde]] <- 37 | list(name = dat$meta$c$use_dde, 38 | location = "internal", 39 | storage_type = "bool", 40 | rank = 0L, 41 | dimnames = NULL) 42 | } 43 | 44 | rewrite <- function(x) { 45 | generate_c_sexp(x, dat$data, dat$meta, dat$config$include$names) 46 | } 47 | 48 | eqs <- generate_c_equations(dat, rewrite) 49 | headers <- generate_c_compiled_headers() 50 | struct <- generate_c_compiled_struct(dat) 51 | core <- generate_c_compiled(eqs, dat, rewrite) 52 | 53 | is_package <- !is.null(package) 54 | lib <- generate_c_compiled_library(dat, is_package) 55 | include <- generate_c_compiled_include(dat) 56 | 57 | if (dat$features$has_delay && dat$features$discrete) { 58 | ring <- generate_c_support_ring(is_package) 59 | } else { 60 | ring <- NULL 61 | } 62 | 63 | if (dat$features$has_interpolate) { 64 | interpolate <- generate_c_support_interpolate(is_package) 65 | } else { 66 | interpolate <- NULL 67 | } 68 | 69 | if (is.null(package)) { 70 | decl <- c(headers, 71 | ring$declarations, 72 | interpolate$declarations, 73 | struct, 74 | core$declaration, 75 | lib$declaration, 76 | unname(include$declarations)) 77 | defn <- c(core$definition, 78 | lib$definition, 79 | ring$definitions, 80 | interpolate$definitions, 81 | unname(include$definitions)) 82 | list(code = c(decl, defn), core = core$name) 83 | } else { 84 | list(headers = headers, 85 | struct = struct, 86 | code = core, 87 | core = core$name, 88 | lib = lib, 89 | include = include, 90 | ring = ring, 91 | interpolate = interpolate) 92 | } 93 | } 94 | -------------------------------------------------------------------------------- /tests/testthat/test-opt.R: -------------------------------------------------------------------------------- 1 | context("opt") 2 | 3 | test_that("static_eval completely evaluates numeric expressions", { 4 | expect_equal(static_eval(quote(1 + 2)), 3) 5 | expect_equal(static_eval(quote(1 + 2 + 3)), 6) 6 | expect_equal(static_eval(quote(1 + 2 * 3)), 7) 7 | expect_equal(static_eval(quote(1 + (2) + 3)), 6) 8 | expect_equal(static_eval(quote((1 + 2) * 3)), 9) 9 | }) 10 | 11 | 12 | test_that("static_eval collects numbers up associatively", { 13 | expect_equal(static_eval(quote(a + 3 + 2)), quote(a + 5)) 14 | expect_equal(static_eval(quote(3 + a + 2)), quote(a + 5)) 15 | expect_equal(static_eval(quote(3 + 2 + a)), quote(a + 5)) 16 | 17 | expect_equal(static_eval(quote(a * 3 * 2)), quote(a * 6)) 18 | expect_equal(static_eval(quote(3 * a * 2)), quote(a * 6)) 19 | expect_equal(static_eval(quote(3 * 2 * a)), quote(a * 6)) 20 | 21 | expect_equal(static_eval(quote(a + 1 + b + 2 + c + 3)), 22 | quote(a + b + c + 6)) 23 | }) 24 | 25 | 26 | test_that("static_eval removes superfluous parens", { 27 | expect_equal(static_eval(quote(1 + (a + 2))), quote(a + 3)) 28 | expect_equal(static_eval(quote(1 + (a + 2) + 3)), quote(a + 6)) 29 | }) 30 | 31 | 32 | test_that("More complex examples", { 33 | expect_equal(static_eval(quote((a + 2 * 3) + 4 * 5)), 34 | quote(a + 26)) 35 | expect_equal(static_eval(quote((a + 2 * 3) + 4 * b)), 36 | quote(b * 4 + a + 6)) 37 | expect_equal(static_eval(quote((1 + 4) * (b + 3))), 38 | quote((b + 3) * 5)) 39 | }) 40 | 41 | 42 | test_that("sort expressions", { 43 | expect_equal( 44 | static_eval(quote(a + 1 + b + 2)), 45 | quote(a + b + 3)) 46 | expect_equal( 47 | static_eval(quote(1 + b + a + 2)), 48 | quote(a + b + 3)) 49 | expect_equal( 50 | static_eval(quote(1 + b + a + 2 + x * y)), 51 | quote(x * y + a + b + 3)) 52 | }) 53 | 54 | 55 | test_that("Addition of zero is a noop", { 56 | expect_equal(static_eval(quote(a + 0)), quote(a)) 57 | expect_equal(static_eval(quote(a + 0 + b)), quote(a + b)) 58 | }) 59 | 60 | 61 | test_that("Multiplication by one is a noop", { 62 | expect_equal(static_eval(quote(a * 1)), quote(a)) 63 | expect_equal(static_eval(quote(a * 1 * b)), quote(a * b)) 64 | }) 65 | 66 | 67 | test_that("Multiplication by zero is catatrophic", { 68 | expect_equal(static_eval(quote(a * 0)), 0) 69 | expect_equal(static_eval(quote(a * 0 * b)), 0) 70 | }) 71 | 72 | 73 | test_that("Can evaluate very long expressions", { 74 | v <- sprintf("x%d", seq_len(200)) 75 | e <- parse(text = paste(v, collapse = " + "))[[1]] 76 | expect_equal( 77 | static_eval(e), 78 | r_fold_call("+", lapply(sort(v), as.name))) 79 | }) 80 | 81 | 82 | test_that("Can collect linear combinations", { 83 | expect_equal( 84 | static_eval(quote(a + b + a + b + a + 4)), 85 | quote(a * 3 + b * 2 + 4)) 86 | ## This is something to pick up later 87 | expect_equal( 88 | static_eval(quote(a + 1 * (a + a))), 89 | quote(a * 2 + a)) 90 | }) 91 | 92 | 93 | test_that("cope with adding zeros", { 94 | expect_equal( 95 | static_eval(quote(0 + 0)), 96 | 0) 97 | expect_equal( 98 | static_eval(quote(0 * x + 1 * 0)), 99 | 0) 100 | }) 101 | -------------------------------------------------------------------------------- /R/opt.R: -------------------------------------------------------------------------------- 1 | ## things not done: 2 | ## Can resolve x - y for numeric args 3 | ## Can simplify a + b - c by rewriting as a + b + (-c) 4 | ## Pointless parens 5 | ## Don't cope with unary +/- 6 | ## Factorise simple linear combinations in +? 7 | 8 | ## Part of the point of this is to assemble expressions into forms 9 | ## that an optimising compiler later in the chain can simplify. 10 | static_eval <- function(expr) { 11 | if (!is.recursive(expr)) { 12 | return(expr) 13 | } 14 | 15 | if (is_call(expr, "+") || is_call(expr, "*")) { 16 | expr <- static_eval_assoc(expr) 17 | } else if (is_call(expr, "if")) { 18 | expr <- static_eval_if(expr) 19 | } else { 20 | expr[-1] <- lapply(expr[-1], static_eval) 21 | } 22 | 23 | if (is_call(expr, "(") && length(expr) == 2L) { 24 | expr <- expr[[2L]] 25 | } 26 | 27 | expr 28 | } 29 | 30 | 31 | static_eval_assoc <- function(expr) { 32 | expr <- flatten_assoc(expr) 33 | expr[-1] <- lapply(expr[-1], static_eval) 34 | 35 | ## We need a *second* round here of flatten_assoc 36 | expr <- flatten_assoc(expr) 37 | 38 | fn <- as.character(expr[[1]]) 39 | args <- expr[-1L] 40 | 41 | i <- vlapply(args, is.numeric) 42 | if (any(i)) { 43 | args <- c(args[!i], eval(r_fold_call(fn, args[i]), baseenv())) 44 | } 45 | 46 | if (fn == "+") { 47 | args <- args[!vlapply(args, function(x) is.numeric(x) && x == 0)] 48 | if (length(args) == 0) { 49 | return(0) 50 | } 51 | 52 | ## Collect linear combinations of shared parameters here; this 53 | ## causes issues for simplifying general expressions (e.g., a + 1 54 | ## * (a + a) will end up as 2 * a + a) but odin doesn't generate 55 | ## things like that (yet). 56 | i <- match(args, args) 57 | if (anyDuplicated(i)) { 58 | for (k in unique(i[duplicated(i)])) { 59 | args[[k]] <- call("*", args[[k]], as.numeric(sum(i == k))) 60 | } 61 | args <- args[!duplicated(i)] 62 | } 63 | } 64 | 65 | if (fn == "*") { 66 | if (any(vlapply(args, function(x) is.numeric(x) && x == 0))) { 67 | args <- list(0) 68 | } 69 | args <- args[!vlapply(args, function(x) is.numeric(x) && x == 1)] 70 | } 71 | 72 | if (length(args) == 1L) { 73 | return(args[[1L]]) 74 | } 75 | 76 | r_fold_call(fn, order_args(args)) 77 | } 78 | 79 | 80 | static_eval_if <- function(expr) { 81 | args <- lapply(expr[-1], static_eval) 82 | 83 | cond <- args[[1L]] 84 | if (is.recursive(cond) && all(vlapply(cond[-1L], is.numeric))) { 85 | cond <- eval(cond, baseenv()) 86 | } 87 | 88 | if (!is.recursive(cond)) { 89 | expr <- if (as.logical(cond)) args[[2L]] else args[[3L]] 90 | } else { 91 | expr[-1L] <- args 92 | } 93 | 94 | expr 95 | } 96 | 97 | 98 | order_args <- function(args) { 99 | i <- viapply(args, function(x) is.language(x) + is.recursive(x)) 100 | args[order(-i, vcapply(args, deparse_str))] 101 | } 102 | 103 | 104 | flatten_assoc <- function(expr) { 105 | fn <- expr[[1L]] 106 | check <- as.list(expr[-1L]) 107 | args <- list() 108 | while (length(check) > 0) { 109 | i <- vlapply(check, is_call, fn) 110 | args <- c(args, check[!i]) 111 | check <- unlist(lapply(check[i], function(x) as.list(x[-1])), FALSE) 112 | } 113 | 114 | c(list(fn), args) 115 | } 116 | -------------------------------------------------------------------------------- /R/generate_c_support.R: -------------------------------------------------------------------------------- 1 | ## This generates non-inclusive ranges; so a full sum will be passed 2 | ## in as: 3 | ## 4 | ## > odin_sum1(x, 0, length(x)) 5 | ## 6 | ## The rewriter generate_c_sexp_sum takes care of converting 'from' 7 | ## into a base-0 index 8 | generate_c_support_sum <- function(rank) { 9 | i <- seq_len(rank) 10 | 11 | ## TODO: would be nice to avoid use of array_dim_name and INDEX 12 | ## here, though in general they are not needed as function scope 13 | ## avoids the worst of things. 14 | index <- INDEX[i] 15 | mult <- vcapply(seq_len(rank), function(x) { 16 | array_dim_name("x", paste(seq_len(x - 1), collapse = "")) 17 | }) 18 | counter <- vcapply(index, strrep, n = 2, USE.NAMES = FALSE) 19 | 20 | limits <- rbind(sprintf_safe("from_%s", index), 21 | sprintf_safe("to_%s", index)) 22 | args <- c("x", limits, mult[-1]) 23 | names(args) <- c("double*", rep("int", length(args) - 1)) 24 | 25 | loop_open <- sprintf_safe("for (int %s = %s; %s < %s; ++%s) {", 26 | index, limits[1, i], index, limits[2, i], index) 27 | 28 | for (j in i) { 29 | if (j == 1L) { 30 | loop_body <- sprintf_safe("tot += x[%s + %s];", 31 | index[[j]], counter[[j + 1]]) 32 | } else { 33 | if (j == rank) { 34 | set_counter <- sprintf_safe("int %s = %s * %s;", 35 | counter[[j]], index[[j]], mult[[j]]) 36 | } else { 37 | set_counter <- sprintf_safe("int %s = %s * %s + %s;", 38 | counter[[j]], index[[j]], 39 | mult[[j]], counter[[j + 1]]) 40 | } 41 | loop_body <- c(set_counter, loop) 42 | } 43 | loop <- c(loop_open[[j]], paste0(" ", loop_body), "}") 44 | } 45 | 46 | body <- c("double tot = 0.0;", loop, "return tot;") 47 | 48 | c_function("double", 49 | sprintf_safe("odin_sum%d", rank), 50 | args, 51 | body) 52 | } 53 | 54 | 55 | generate_c_support_ring <- function(is_package) { 56 | generate_c_support_external("include/ring/ring.h", "include/ring/ring.c", 57 | "ring", is_package) 58 | } 59 | 60 | 61 | generate_c_support_interpolate <- function(is_package) { 62 | generate_c_support_external("include/cinterpolate/cinterpolate.h", 63 | "include/cinterpolate/cinterpolate.c", 64 | "cinterpolate", is_package) 65 | } 66 | 67 | 68 | ## TODO: later on, we should look for LinkingTo within the package 69 | ## DESCRIPTION because if it is found then we can do a different, 70 | ## probably better, approach. The net effect on compile time and 71 | ## object size will be the same however. 72 | generate_c_support_external <- function(path_h, path_c, package, is_package) { 73 | filter_includes <- function(filename) { 74 | x <- readLines(filename) 75 | x[!grepl("^#include\\s+", x, perl = TRUE)] 76 | } 77 | 78 | filename_h <- system.file(path_h, package = package, mustWork = TRUE) 79 | filename_c <- system.file(path_c, package = package, mustWork = TRUE) 80 | 81 | if (is_package) { 82 | decl <- filter_includes(filename_h) 83 | defn <- filter_includes(filename_c) 84 | } else { 85 | decl <- sprintf('#include "%s"', filename_h) 86 | defn <- sprintf('#include "%s"', filename_c) 87 | } 88 | 89 | list(declarations = decl, definitions = defn) 90 | } 91 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-unused.R: -------------------------------------------------------------------------------- 1 | context("parse: unused variables") 2 | 3 | test_that("no unused variables", { 4 | expect_silent(odin_parse({ 5 | deriv(y) <- 1 6 | initial(y) <- 0 7 | })) 8 | }) 9 | 10 | test_that("one unused variable", { 11 | expect_message(odin_parse({ 12 | deriv(y) <- 1 13 | initial(y) <- 0 14 | a <- 1 15 | }, options = odin_options(rewrite_constants = FALSE)), 16 | "Unused equation: a") 17 | 18 | expect_silent(odin_parse({ 19 | deriv(y) <- 1 20 | initial(y) <- 0 21 | a <- 1 22 | }, options = odin_options(rewrite_constants = FALSE, 23 | no_check_unused_equations = TRUE))) 24 | }) 25 | 26 | test_that("more than one unused variable", { 27 | expect_message(odin_parse({ 28 | deriv(y) <- 1 29 | initial(y) <- 0 30 | a <- 1 31 | b <- 2 32 | }, options = odin_options(rewrite_constants = FALSE)), 33 | "Unused equations: a, b") 34 | }) 35 | 36 | test_that("dependent unused variables", { 37 | expect_message(odin_parse({ 38 | deriv(y) <- 1 39 | initial(y) <- 0 40 | a <- 1 41 | b <- a * 2 42 | }, options = odin_options(rewrite_constants = FALSE)), 43 | "Unused equations: a, b") 44 | }) 45 | 46 | test_that("dependent non-unused variables", { 47 | expect_silent(odin_parse({ 48 | deriv(y) <- b 49 | initial(y) <- 0 50 | a <- 1 51 | b <- a * 2 52 | }, options = odin_options(rewrite_constants = FALSE))) 53 | }) 54 | 55 | test_that("delayed non-unused variables", { 56 | expect_silent(odin_parse({ 57 | ylag <- delay(y + a, 10) 58 | initial(y) <- 0.5 59 | deriv(y) <- 0.2 * ylag * 1 / (1 + ylag^10) - 0.1 * y 60 | a <- 1 61 | })) 62 | }) 63 | 64 | test_that("dimension names get cleaned", { 65 | expect_message( 66 | odin_parse({ 67 | deriv(y[]) <- y[i] * r[i] 68 | initial(y[]) <- i + 1 69 | y0[] <- i + 1 70 | dim(y0) <- 3 71 | dim(y) <- 3 72 | dim(r) <- 3 73 | r[] <- user() 74 | output(yr[]) <- y[i] / (i + 1) 75 | dim(yr) <- 3 76 | output(r[]) <- TRUE 77 | config(base) <- "mod" 78 | }), "Unused equation: y0") 79 | }) 80 | 81 | 82 | test_that("don't be too noisy", { 83 | expect_silent(odin_parse({ 84 | initial(y[, , ]) <- 1 85 | deriv(y[, , ]) <- y[i, j, k] * 0.1 86 | dim(y) <- c(2, 3, 4) 87 | })) 88 | }) 89 | 90 | 91 | test_that("Can suppress unused variables with a comment", { 92 | f <- function(code) { 93 | odin_parse_(c("initial(x) <- 0", "deriv(x) <- 0", code)) 94 | } 95 | expect_silent(f("a <- user(1) # ignore.unused")) 96 | ## If the expression is split over two lines we pick it up: 97 | expect_silent(f(c("a <-", " user(1) # ignore.unused"))) 98 | expect_silent(f(c("a <- # ignore.unused", " user(1)"))) 99 | 100 | expect_message(f("a <- user(1) # ignoreUnused"), 101 | "Unused equation: a") 102 | expect_message(f(c("a <- user(1) # ignore.unused", 103 | "b <- user(2)")), 104 | "Unused equation: b") 105 | 106 | ## Constants are ok 107 | expect_silent(f("xxx <- 10 # ignore.unused")) 108 | 109 | ## Time varying things should not be removed because they won't be 110 | ## calculated 111 | expect_message( 112 | f("xxx <- 10 * t # ignore.unused"), 113 | "Unused equation marked as ignored will be dropped: xxx") 114 | }) 115 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-data.R: -------------------------------------------------------------------------------- 1 | test_that("Can parse with a data element", { 2 | ir <- odin_parse({ 3 | initial(x) <- 1 4 | update(x) <- rnorm(0, 0.1) 5 | d <- data() 6 | }) 7 | d <- ir_deserialise(ir) 8 | expect_length(d$equations, 2) 9 | expect_true(d$features$has_data) 10 | expect_mapequal( 11 | d$data$elements$d, 12 | list(name = "d", location = "data", storage_type = "double", 13 | rank = 0L, dimnames = NULL, stage = "time")) 14 | }) 15 | 16 | 17 | test_that("Can parse with a data element", { 18 | expect_error( 19 | odin_parse({ 20 | initial(x) <- 1 21 | update(x) <- rnorm(0, 0.1) 22 | d <- data(1, 2) 23 | }), 24 | "Calls to data() must have no arguments", 25 | fixed = TRUE) 26 | }) 27 | 28 | 29 | test_that("Can parse with a compare expression", { 30 | ir <- odin_parse({ 31 | initial(x) <- 1 32 | update(x) <- rnorm(0, 0.1) 33 | d <- data() 34 | compare(d) ~ normal(0, 1) 35 | }) 36 | d <- ir_deserialise(ir) 37 | 38 | expect_length(d$equations, 3) 39 | expect_mapequal( 40 | d$equations$compare_d, 41 | list(name = "compare_d", 42 | type = "compare", 43 | source = list(4), 44 | depends = list(functions = character(), variables = "d"), 45 | lhs = "d", 46 | compare = list(distribution = "normal", 47 | args = list(0, 1)))) 48 | }) 49 | 50 | 51 | test_that("correct components", { 52 | ir <- odin_parse({ 53 | initial(x) <- 1 54 | update(x) <- rnorm(0, 2 * sd) 55 | d <- data() 56 | sd <- user() 57 | compare(d) ~ normal(x, sd) 58 | }) 59 | d <- ir_deserialise(ir) 60 | expect_equal( 61 | d$components$update, 62 | list(variables = character(), equations = character())) 63 | expect_equal( 64 | d$components$compare, 65 | list(variables = "x", equations = "compare_d")) 66 | }) 67 | 68 | 69 | test_that("can't refer to data outside of compare", { 70 | expect_error( 71 | odin_parse({ 72 | initial(x) <- 1 73 | update(x) <- rnorm(0, 2 * d) 74 | d <- data() 75 | }), 76 | "Data ('d') may only be referred to in compare expressions", 77 | fixed = TRUE) 78 | }) 79 | 80 | 81 | test_that("compare expressions must use ~ not <-", { 82 | expect_error( 83 | odin_parse({ 84 | initial(x) <- 1 85 | update(x) <- rnorm(0, 0.1) 86 | d <- data() 87 | compare(d) <- normal(0, 1) 88 | }), 89 | "All compare() expressions must use '~' and not '<-' or '='", 90 | fixed = TRUE) 91 | }) 92 | 93 | 94 | test_that("compare expressions must be a call", { 95 | expect_error( 96 | odin_parse({ 97 | initial(x) <- 1 98 | update(x) <- rnorm(0, 0.1) 99 | d <- data() 100 | compare(d) ~ normal 101 | }), 102 | "Expected rhs of compare() expression to be a call", 103 | fixed = TRUE) 104 | }) 105 | 106 | 107 | test_that("compare expressions must be a call", { 108 | expect_error( 109 | odin_parse({ 110 | initial(x) <- 1 111 | update(x) <- rnorm(0, 0.1) 112 | d <- data() 113 | compare(d) ~ exciting(0, 1) 114 | }), 115 | "Expected rhs to be a valid distribution", 116 | fixed = TRUE) 117 | }) 118 | 119 | 120 | test_that("negative binomial still can't use args", { 121 | expect_error( 122 | odin_parse({ 123 | initial(x) <- 1 124 | update(x) <- rnorm(0, 0.1) 125 | d <- data() 126 | compare(d) ~ normal(mean = 0, sd = 1) 127 | }), 128 | "Named argument calls not supported in odin", 129 | fixed = TRUE) 130 | }) 131 | -------------------------------------------------------------------------------- /tests/testthat/test-preprocess.R: -------------------------------------------------------------------------------- 1 | context("preprocess") 2 | 3 | test_that("text", { 4 | src <- c("deriv(y) <- 0.5", 5 | "initial(y) <- 1") 6 | f <- function(x) lapply(x$exprs, identity) 7 | cmp <- lapply(parse(text = src), identity) 8 | 9 | ## Accept the source as a string: 10 | expect_equal(odin_preprocess_detect(src), "text") 11 | expect_equal(f(odin_preprocess(src)), cmp) 12 | expect_equal(odin_preprocess_detect(paste(src, collapse = "\n")), "text") 13 | expect_equal(odin_preprocess_detect(paste(src, collapse = ";")), "text") 14 | expect_equal(f(odin_preprocess(paste(src, collapse = "\n"))), cmp) 15 | expect_equal(f(odin_preprocess(paste(src, collapse = ";"))), cmp) 16 | 17 | dest <- tempfile() 18 | writeLines(src, dest) 19 | expect_equal(odin_preprocess_detect(dest), "file") 20 | expect_equal(f(odin_preprocess(dest)), cmp) 21 | 22 | expect_error(odin_preprocess(tempfile()), 23 | "looks like a filename, but file does not exist") 24 | expect_error(odin_preprocess("somefile.R"), 25 | "'somefile.R' looks like a filename, but file does not exist") 26 | 27 | expect_error(odin_preprocess(1L), "Invalid type") 28 | expect_error(odin_preprocess(pi), "Invalid type") 29 | expect_error(odin_preprocess(sin), "Invalid type") 30 | expect_error(odin_preprocess(1.0), "Invalid type") 31 | }) 32 | 33 | 34 | test_that("type detection avoids unlikely filenames", { 35 | expect_error(odin_preprocess_detect("x"), "looks like a filename") 36 | expect_equal(odin_preprocess_detect("x <- y"), "text") 37 | expect_equal(odin_preprocess_detect("x = y"), "text") 38 | ## Note that we do allow 'deriv(x)' as a sort of filename here, 39 | ## perhaps not ideal, but it feels unlikely. 40 | expect_equal(odin_preprocess_detect("deriv(x) = 1"), "text") 41 | }) 42 | 43 | 44 | test_that("type detection can skip filenames", { 45 | expect_error(odin_preprocess_detect("x", NULL), "looks like a filename") 46 | expect_equal(odin_preprocess_detect("x", "text"), "text") 47 | expect_error(odin_preprocess_detect("x", "file"), "does not exist") 48 | }) 49 | 50 | 51 | test_that("detect invalid type", { 52 | expect_error(odin_preprocess_detect("x", "expression"), 53 | "Invalid input for odin - expected expression") 54 | expect_error(odin_preprocess_detect(quote(x), "text"), 55 | "Invalid input for odin - expected text") 56 | expect_error(odin_preprocess_detect(quote(x), "file"), 57 | "Invalid input for odin - expected file") 58 | }) 59 | 60 | 61 | test_that("handle empty input", { 62 | ## Previously errored 63 | expect_equal(odin_preprocess_detect(character(0)), "text") 64 | }) 65 | 66 | 67 | test_that("sanitise filenames", { 68 | path <- tempfile() 69 | dir.create(path) 70 | on.exit(unlink(path, recursive = TRUE)) 71 | 72 | code <- c("initial(x) <- 1", "deriv(x) <- 1") 73 | 74 | path_hyphens <- file.path(path, "path-with-hyphens.R") 75 | path_spaces <- file.path(path, "path with spaces.R") 76 | path_parens1 <- file.path(path, "path_with_parens (1).R") 77 | path_parens2 <- file.path(path, "path_with_parens (a).R") 78 | path_dots <- file.path(path, "path_with.dots.R") 79 | writeLines(code, path_hyphens) 80 | writeLines(code, path_spaces) 81 | writeLines(code, path_parens1) 82 | writeLines(code, path_parens2) 83 | writeLines(code, path_dots) 84 | 85 | expect_equal(odin_preprocess(path_hyphens)$base, 86 | "path_with_hyphens") 87 | expect_equal(odin_preprocess(path_spaces)$base, 88 | "path_with_spaces") 89 | expect_equal(odin_preprocess(path_parens1)$base, 90 | "path_with_parens") 91 | expect_equal(odin_preprocess(path_parens2)$base, 92 | "path_with_parens_a") 93 | expect_equal(odin_preprocess(path_dots)$base, 94 | "path_with_dots") 95 | }) 96 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-config.R: -------------------------------------------------------------------------------- 1 | context("parse: config") 2 | 3 | test_that("invalid options", { 4 | expect_error(odin_parse("config(a) <- 1;"), 5 | "Unknown configuration option: a", 6 | class = "odin_error") 7 | }) 8 | 9 | test_that("config() takes a symbol", { 10 | expect_error(odin_parse("config('base') <- 1;"), 11 | "Argument to config must be a symbol", 12 | class = "odin_error") 13 | }) 14 | 15 | test_that("config(base)", { 16 | expect_error(odin_parse("config(base) <- 'foo'; config(base) <- 'foo'"), 17 | "Expected a single config(base) option", 18 | fixed = TRUE, class = "odin_error") 19 | expect_error(odin_parse("config(base) <- foo;"), 20 | "Expected a character for config(base) but recieved a symbol", 21 | fixed = TRUE, class = "odin_error") 22 | expect_error( 23 | odin_parse("config(base) <- 1;"), 24 | "Expected a character for config(base) but recieved a double", 25 | fixed = TRUE, class = "odin_error") 26 | 27 | ## some invalid identifiers: 28 | expect_error(odin_parse("config(base) <- '1foo';"), 29 | "must be a valid C identifier", 30 | fixed = TRUE, class = "odin_error") 31 | expect_error(odin_parse("config(base) <- '*foo';"), 32 | "must be a valid C identifier", 33 | fixed = TRUE, class = "odin_error") 34 | expect_error(odin_parse("config(base) <- '-foo';"), 35 | "must be a valid C identifier", 36 | fixed = TRUE, class = "odin_error") 37 | expect_error(odin_parse("config(base) <- '.foo';"), 38 | "must be a valid C identifier", 39 | fixed = TRUE, class = "odin_error") 40 | }) 41 | 42 | test_that("config(include)", { 43 | options <- odin_options(target = "c") 44 | expect_error(odin_parse_(quote(config(include) <- 1), options), 45 | "Expected a character for config(include)", 46 | fixed = TRUE, class = "odin_error") 47 | 48 | expect_error(odin_parse_(quote(config(include) <- "no file.c"), options), 49 | "Could not find file 'no file.c'", 50 | fixed = TRUE, class = "odin_error") 51 | 52 | expect_error(odin_parse( 53 | 'config(include) <- "user_fns.c"; config(include) <- "user_fns.c"', 54 | options = options), 55 | "Duplicated function 'squarepulse' while reading includes", 56 | class = "odin_error") 57 | }) 58 | 59 | 60 | test_that("Can include multiple files", { 61 | ir <- odin_parse({ 62 | config(include) <- "user_fns.c" 63 | config(include) <- "identity.c" 64 | initial(x) <- 1 65 | deriv(x) <- 1 66 | }, options = odin_options(target = "c")) 67 | dat <- ir_deserialise(ir) 68 | expect_length(dat$config$include, 2) 69 | expect_equal( 70 | vcapply(dat$config$include$data, function(x) basename(x$filename[[1]])), 71 | c("user_fns.c", "identity.c")) 72 | }) 73 | 74 | 75 | test_that("extend config", { 76 | options <- odin_options(target = "c") 77 | options$config_custom <- "a" 78 | 79 | ir <- odin_parse({ 80 | config(a) <- 1 81 | initial(x) <- 1 82 | deriv(x) <- 1 83 | }, options = options) 84 | expect_equal(ir_deserialise(ir)$config$custom, 85 | list(list(name = "a", value = 1))) 86 | 87 | ir <- odin_parse({ 88 | config(a) <- 1 89 | config(a) <- 2 90 | initial(x) <- 1 91 | deriv(x) <- 1 92 | }, options = options) 93 | expect_equal(ir_deserialise(ir)$config$custom, 94 | list(list(name = "a", value = 1), 95 | list(name = "a", value = 2))) 96 | 97 | expect_error( 98 | odin_parse({ 99 | config(a) <- 1 100 | config(b) <- 2 101 | initial(x) <- 1 102 | deriv(x) <- 1 103 | }, options = options), 104 | "Unknown configuration option: b") 105 | }) 106 | -------------------------------------------------------------------------------- /R/dependencies.R: -------------------------------------------------------------------------------- 1 | find_symbols <- function(expr, hide_errors = TRUE) { 2 | if (is.list(expr)) { 3 | return(join_deps(lapply(expr, find_symbols))) 4 | } 5 | functions <- collector() 6 | variables <- collector() 7 | 8 | f <- function(e) { 9 | if (!is.recursive(e)) { 10 | if (!is.symbol(e)) { # A literal of some type 11 | return() 12 | } 13 | variables$add(deparse(e)) 14 | } else { 15 | nm <- deparse(e[[1L]]) 16 | if (nm %in% c("dim", "length")) { 17 | ## These functions are treated separately because length(X) does 18 | ## not depend on the value of X so much as the *length*. That's 19 | ## handled by a separate variable that we hook up here. 20 | if (length(e) >= 2L) { 21 | ## The if here avoids an invalid parse, e.g. length(); we'll 22 | ## pick that up later on. 23 | ## This is the one problematic use 24 | variables$add(array_dim_name(deparse(e[[2L]]))) 25 | } 26 | ## Still need to declare the function as used because we'll 27 | ## want to check that later. 28 | functions$add(nm) 29 | } else { 30 | functions$add(deparse(e[[1]])) 31 | for (a in as.list(e[-1])) { 32 | if (!missing(a)) { 33 | f(a) 34 | } 35 | } 36 | } 37 | } 38 | } 39 | 40 | f(expr) 41 | list(functions = unique(functions$get()), 42 | variables = unique(variables$get())) 43 | } 44 | 45 | join_deps <- function(x) { 46 | stopifnot(is.list(x)) 47 | x <- x[!vlapply(x, is.null)] 48 | ## This should never be triggered 49 | ok <- vlapply(x, function(el) { 50 | identical(names(el), c("functions", "variables")) 51 | }) 52 | stopifnot(all(ok)) 53 | if (length(x) == 0L) { 54 | list(functions = character(0), variables = character(0)) 55 | } else if (length(x) == 1L) { 56 | x[[1L]] 57 | } else { 58 | list(functions = unique(unlist(lapply(x, "[[", "functions"))), 59 | variables = unique(unlist(lapply(x, "[[", "variables")))) 60 | } 61 | } 62 | 63 | ## This algorithm comes from here: 64 | ## http://blog.jupo.org/2012/04/06/topological-sorting-acyclic-directed-graphs/ 65 | ## and assumes that the graph is expressed as a *named* list. The 66 | ## daughters of an element are its dependencies. 67 | topological_order <- function(graph) { 68 | m <- matrix(FALSE, length(graph), length(graph)) 69 | for (i in seq_along(graph)) { 70 | m[, i] <- unname(names(graph) %in% graph[[i]]) 71 | } 72 | 73 | pending <- rep(TRUE, length(graph)) 74 | graph_sorted <- integer(0) 75 | while (any(pending)) { 76 | i <- which(pending)[colSums(m[, pending, drop = FALSE]) == 0] 77 | if (length(i) > 0L) { 78 | graph_sorted <- c(graph_sorted, i) 79 | pending[i] <- FALSE 80 | m[i, ] <- FALSE 81 | } else { 82 | f <- function(i) { 83 | ## Note that this is not going to give the right answer here 84 | ## but it might still be useful (dim_x -> dim(x), initial_x -> 85 | ## initial(x) etc.) Could swap these around with 86 | ## RESERVED_PREFIX perhaps. 87 | sprintf("\t%s: depends on %s", 88 | names(graph)[[i]], paste(err[m[pending, i]], collapse = ", ")) 89 | } 90 | err <- names(graph)[pending] 91 | detail <- paste(vcapply(which(pending), f), collapse = "\n") 92 | stop(sprintf("A cyclic dependency detected for %s:\n%s", 93 | paste(names(graph)[pending], collapse = ", "), 94 | detail), call. = FALSE) 95 | } 96 | } 97 | 98 | names(graph)[graph_sorted] 99 | } 100 | 101 | 102 | recursive_dependencies <- function(order, deps, vars) { 103 | deps_rec <- setNames(vector("list", length(order)), order) 104 | for (i in order) { 105 | j <- as.character(unlist(deps[i])) 106 | deps_rec[[i]] <- 107 | c(j, unique(as.character(unlist(deps_rec[j], use.names = FALSE)))) 108 | } 109 | deps_rec 110 | } 111 | -------------------------------------------------------------------------------- /R/generate_c_utils.R: -------------------------------------------------------------------------------- 1 | c_variable_reference <- function(x, data_info, state, rewrite) { 2 | if (data_info$rank == 0L) { 3 | sprintf("%s[%s]", state, rewrite(x$offset)) 4 | } else { 5 | sprintf("%s + %s", state, rewrite(x$offset)) 6 | } 7 | } 8 | 9 | 10 | c_flatten_eqs <- function(eqs) { 11 | unlist(unname(eqs)) 12 | } 13 | 14 | 15 | c_function <- function(return_type, name, args, body) { 16 | args_str <- paste(sprintf_safe("%s %s", names(args), unname(args)), 17 | collapse = ", ") 18 | str <- sprintf_safe("%s %s(%s)", return_type, name, args_str) 19 | list(name = name, 20 | declaration = paste0(str, ";"), 21 | definition = c(paste0(str, " {"), paste0(" ", body), "}")) 22 | } 23 | 24 | 25 | c_unpack_variable <- function(name, dat, state, rewrite) { 26 | el <- dat$data$variable$contents[[name]] 27 | data_info <- dat$data$elements[[el$name]] 28 | rhs <- c_variable_reference(el, data_info, state, rewrite) 29 | if (data_info$rank == 0L) { 30 | fmt <- "%s %s = %s;" 31 | } else { 32 | fmt <- "%s * %s = %s;" 33 | } 34 | sprintf(fmt, data_info$storage_type, el$name, rhs) 35 | } 36 | 37 | 38 | ## TODO: harmoise with the above - mostly this is rewriting previous uses 39 | c_unpack_variable2 <- function(x, data_elements, state, rewrite) { 40 | rhs <- c_extract_variable(x, data_elements, state, rewrite) 41 | sprintf_safe("%s = %s;", x$name, rhs) 42 | } 43 | 44 | 45 | ## TODO: this is the same as c_variable_reference 46 | c_extract_variable <- function(x, data_elements, state, rewrite) { 47 | d <- data_elements[[x$name]] 48 | if (d$rank == 0L) { 49 | sprintf("%s[%s]", state, rewrite(x$offset)) 50 | } else { 51 | sprintf("%s + %s", state, rewrite(x$offset)) 52 | } 53 | } 54 | 55 | 56 | c_type_info <- function(storage_type) { 57 | if (storage_type == "double") { 58 | sexp_name <- "REALSXP" 59 | sexp_access <- "REAL" 60 | scalar_allocate <- "ScalarReal" 61 | } else if (storage_type == "int") { 62 | sexp_name <- "INTSXP" 63 | sexp_access <- "INTEGER" 64 | scalar_allocate <- "ScalarInteger" 65 | } else if (storage_type == "bool") { 66 | sexp_name <- "LGLSXP" 67 | sexp_access <- "INTEGER" 68 | scalar_allocate <- "ScalarLogical" 69 | } else { 70 | stop(sprintf("Invalid type %s [odin bug]", storage_type)) # nocov 71 | } 72 | list(c_name = storage_type, 73 | sexp_name = sexp_name, 74 | sexp_access = sexp_access, 75 | scalar_allocate = scalar_allocate) 76 | } 77 | 78 | 79 | c_expr_if <- function(condition, a, b = NULL) { 80 | if (is.null(b)) { 81 | c(sprintf_safe("if (%s) {", condition), 82 | paste0(" ", c_flatten_eqs(a)), 83 | "}") 84 | } else { 85 | c(sprintf_safe("if (%s) {", condition), 86 | paste0(" ", c_flatten_eqs(a)), 87 | "} else {", 88 | paste0(" ", c_flatten_eqs(b)), 89 | "}") 90 | } 91 | } 92 | 93 | 94 | c_fold_call <- function(fn, args) { 95 | if (length(args) == 1L) { 96 | args[[1L]] 97 | } else { 98 | sprintf("%s(%s, %s)", fn, args[[1L]], c_fold_call(fn, args[-1])) 99 | } 100 | } 101 | 102 | 103 | ## See: generate_r_equation_array_lhs 104 | c_array_access <- function(target, index, data, meta, supported) { 105 | mult <- data$elements[[target]]$dimnames$mult 106 | 107 | f <- function(i) { 108 | index_i <- c_minus_1(index[[i]], i > 1, data, meta, supported) 109 | if (i == 1) { 110 | index_i 111 | } else { 112 | mult_i <- generate_c_sexp(mult[[i]], data, meta, supported) 113 | sprintf("%s * %s", mult_i, index_i) 114 | } 115 | } 116 | 117 | paste(vcapply(rev(seq_along(index)), f), collapse = " + ") 118 | } 119 | 120 | 121 | c_minus_1 <- function(x, protect, data, meta, supported) { 122 | if (is.numeric(x)) { 123 | generate_c_sexp(x - 1L, data, meta, supported) 124 | } else { 125 | x_expr <- generate_c_sexp(x, data, meta, supported) 126 | sprintf(if (protect) "(%s - 1)" else "%s - 1", x_expr) 127 | } 128 | } 129 | -------------------------------------------------------------------------------- /R/ir_parse_config.R: -------------------------------------------------------------------------------- 1 | ir_parse_config <- function(eqs, base_default, root, source, 2 | read_include, custom) { 3 | i <- vcapply(eqs, "[[", "type") == "config" 4 | 5 | config <- lapply(unname(eqs[i]), ir_parse_config1, source, custom) 6 | 7 | nms <- vcapply(config, function(x) x$lhs$name_data) 8 | 9 | base <- ir_parse_config_base(config[nms == "base"], base_default, source) 10 | include <- ir_parse_config_include(config[nms == "include"], root, source, 11 | read_include) 12 | custom <- ir_parse_config_custom(config[nms %in% custom], source) 13 | 14 | ret <- list(base = base, include = include) 15 | if (length(custom) > 0) { 16 | ret$custom <- custom 17 | } 18 | ret 19 | } 20 | 21 | 22 | ir_parse_config_base <- function(config, base_default, source) { 23 | if (length(config) == 0L) { 24 | base <- base_default 25 | base_line <- NULL 26 | } else if (length(config) == 1L) { 27 | base <- config[[1]]$rhs$value 28 | base_line <- config[[1]]$source 29 | } else { 30 | ir_parse_error("Expected a single config(base) option", 31 | ir_parse_error_lines(config), source) 32 | } 33 | if (!is_c_identifier(base)) { 34 | ir_parse_error( 35 | sprintf("Invalid base value: '%s', must be a valid C identifier", base), 36 | base_line, source) 37 | } 38 | 39 | base 40 | } 41 | 42 | 43 | ir_parse_config_include <- function(include, root, source, read_include) { 44 | if (length(include) == 0) { 45 | return(NULL) 46 | } 47 | 48 | ## First check that the paths exist: 49 | filename <- vcapply(include, function(x) x$rhs$value) 50 | filename_full <- file.path(root, filename) 51 | msg <- !file.exists(filename_full) 52 | if (any(msg)) { 53 | ## Only throw here on the first, for simplicity 54 | x <- include[msg][[1]] 55 | ir_parse_error( 56 | sprintf("Could not find file '%s' (relative to root '%s')", 57 | x$rhs$value, root), 58 | x$source, source) 59 | } 60 | 61 | res <- lapply(filename_full, function(path) { 62 | withCallingHandlers( 63 | read_include(path), 64 | error = function(e) message(sprintf("While reading '%s'", path))) 65 | }) 66 | 67 | nms <- unlist(lapply(res, "[[", "names")) 68 | dups <- unique(nms[duplicated(nms)]) 69 | if (length(dups) > 0L) { 70 | lines <- vnapply(include, "[[", "source") 71 | ir_parse_error(sprintf("Duplicated function %s while reading includes", 72 | paste(squote(dups), collapse = ", ")), 73 | lines, source) 74 | } 75 | 76 | list(names = nms, 77 | data = lapply(res, "[[", "data")) 78 | } 79 | 80 | 81 | ir_parse_config_custom <- function(x, source) { 82 | if (length(x) == 0) { 83 | return(NULL) 84 | } 85 | 86 | ## Is there any other validation that can really be done? We could 87 | ## require that custom cases conform to particular types or are 88 | ## unique? For now we'll be really leniant since we don't document 89 | ## this as a public interface yet. 90 | name <- vcapply(x, function(el) el$lhs$name_lhs) 91 | value <- lapply(x, function(el) el$rhs$value) 92 | unname(Map(list, name = name, value = value)) 93 | } 94 | 95 | 96 | ir_parse_config1 <- function(eq, source, custom) { 97 | target <- eq$lhs$name_data 98 | value <- eq$rhs$value 99 | 100 | expected_type <- switch( 101 | target, 102 | base = "character", 103 | include = "character", 104 | NULL) 105 | 106 | if (is.null(expected_type)) { 107 | if (!(target %in% custom)) { 108 | ir_parse_error(sprintf("Unknown configuration option: %s", target), 109 | eq$source, source) 110 | } 111 | } else { 112 | if (storage.mode(value) != expected_type) { 113 | ir_parse_error(sprintf( 114 | "Expected a %s for config(%s) but recieved a %s", 115 | expected_type, target, storage.mode(value)), 116 | eq$source, source) 117 | } 118 | } 119 | 120 | eq 121 | } 122 | -------------------------------------------------------------------------------- /R/differentiate-support.R: -------------------------------------------------------------------------------- 1 | make_deterministic <- function(expr) { 2 | if (is.recursive(expr) && is.symbol(expr[[1]])) { 3 | fn <- as.character(expr[[1]]) 4 | if (fn %in% names(deterministic_rules)) { 5 | expr <- deterministic_rules[[fn]](expr) 6 | } 7 | } 8 | if (is.recursive(expr)) { 9 | expr <- as.call(lapply(expr, make_deterministic)) 10 | } 11 | expr 12 | } 13 | 14 | 15 | deterministic_rules <- list( 16 | unif_rand = function(expr) { 17 | 0.5 18 | }, 19 | norm_rand = function(expr) { 20 | 0 21 | }, 22 | exp_rand = function(expr) { 23 | 1 24 | }, 25 | rbeta = function(expr) { 26 | substitute(a / (a + b), list(a = expr[[2]], b = expr[[3]])) 27 | }, 28 | rbinom = function(expr) { 29 | substitute(n * p, list(n = expr[[2]], p = expr[[3]])) 30 | }, 31 | rcauchy = function(expr) { 32 | ## This needs to flow through to line numbers eventually, or we 33 | ## need to throw an error if it remains in the code (so allow it 34 | ## only if it is never used) 35 | stop("The Cauchy distribution has no mean, and may not be used") 36 | }, 37 | rchisq = function(expr) { 38 | expr[[2]] 39 | }, 40 | rexp = function(expr) { 41 | substitute(1 / rate, list(rate = expr[[2]])) 42 | }, 43 | rf = function(expr) { 44 | ## TODO: only valid for df2 > 2! 45 | substitute(df2 / (df2 - 2), list(df2 = expr[[3]])) 46 | }, 47 | rgamma = function(expr) { 48 | substitute(shape / rate, list(shape = expr[[2]], rate = expr[[3]])) 49 | }, 50 | rgeom = function(expr) { 51 | substitute((1 - p) / p, list(p = expr[[2]])) 52 | }, 53 | rhyper = function(expr) { 54 | substitute(k * m / (m + n), 55 | list(m = expr[[2]], n = expr[[3]], k = expr[[4]])) 56 | }, 57 | rlogis = function(expr) { 58 | expr[[2]] 59 | }, 60 | rlnorm = function(expr) { 61 | substitute(exp(mu + sigma^2 / 2), list(mu = expr[[2]], sigma = expr[[3]])) 62 | }, 63 | rnbinom = function(expr) { 64 | substitute(n * (1 - p) / p, list(n = expr[[2]], p = expr[[3]])) 65 | }, 66 | rnorm = function(expr) { 67 | expr[[2]] 68 | }, 69 | rpois = function(expr) { 70 | expr[[2]] 71 | }, 72 | rt = function(expr) { 73 | ## only if df > 1 74 | 0 75 | }, 76 | runif = function(expr) { 77 | substitute((a + b) / 2, list(a = expr[[2]], b = expr[[3]])) 78 | }, 79 | rweibull = function(expr) { 80 | substitute(b * gamma(1 + 1 / a), list(a = expr[[2]], b = expr[[3]])) 81 | }, 82 | rwilcox = function(expr) { 83 | substitute(m * n / 2, list(m = expr[[2]], n = expr[[3]])) 84 | }, 85 | rsignrank = function(expr) { 86 | substitute(n * (n + 1) / 4, list(n = expr[[2]])) 87 | }) 88 | 89 | 90 | ## These are all worked out by manually taking logarithms of the 91 | ## densities - I've not been terribly exhaustive here, but have copied 92 | ## what we use in dust already... 93 | ## 94 | ## The user is going to write out: 95 | ## 96 | ## > compare(d) ~ poisson(lambda) 97 | ## 98 | ## which corresponds to writing 99 | ## 100 | ## > dpois(d, lambda, log = TRUE) 101 | ## ==> log(lambda^x * exp(-lambda) / x!) 102 | ## ==> x * log(lambda) - lambda - lfactorial(x) 103 | ## 104 | ## All the density functions will have the same form here, with the 105 | ## lhs becoming the 'x' argument (all d* functions take 'x' as the 106 | ## first argument). 107 | log_density <- function(distribution, target, args) { 108 | target <- as.name(target) 109 | switch( 110 | distribution, 111 | ## Assumption here is that sd is never zero, which might warrant 112 | ## special treatment (except that it's infinite so probably 113 | ## problematic anyway). 114 | normal = substitute( 115 | - (x - mu)^2 / (2 * sd^2) - log(2 * pi) / 2 - log(sd), 116 | list(x = target, mu = args[[1]], sd = args[[2]])), 117 | poisson = substitute( 118 | x * log(lambda) - lambda - lfactorial(x), 119 | list(x = target, lambda = args[[1]])), 120 | uniform = substitute( 121 | if (x < a || x > b) -Inf else -log(b - a), 122 | list(x = target, a = args[[1]], b = args[[2]])), 123 | stop(sprintf("Unsupported distribution '%s'", distribution))) 124 | } 125 | -------------------------------------------------------------------------------- /man/odin_options.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/odin_options.R 3 | \name{odin_options} 4 | \alias{odin_options} 5 | \title{Odin options} 6 | \usage{ 7 | odin_options(verbose = NULL, target = NULL, workdir = NULL, 8 | validate = NULL, pretty = NULL, skip_cache = NULL, 9 | compiler_warnings = NULL, no_check_unused_equations = NULL, 10 | rewrite_dims = NULL, rewrite_constants = NULL, debug_enable = NULL, 11 | substitutions = NULL, options = NULL) 12 | } 13 | \arguments{ 14 | \item{verbose}{Logical scalar indicating if the compilation should 15 | be verbose. Defaults to the value of the option 16 | \code{odin.verbose} or \code{FALSE} otherwise.} 17 | 18 | \item{target}{Compilation target. Options are "c", "r" or "js", 19 | defaulting to the option \code{odin.target} or "c" otherwise.} 20 | 21 | \item{workdir}{Directory to use for any generated files. This is 22 | only relevant for the "c" target. Defaults to the value of the 23 | option \code{odin.workdir} or \code{\link[=tempdir]{tempdir()}} otherwise.} 24 | 25 | \item{validate}{Validate the model's intermediate representation 26 | against the included schema. Normally this is not needed and is 27 | intended primarily for development use. Defaults to the value 28 | of the option \code{odin.validate} or \code{FALSE} otherwise.} 29 | 30 | \item{pretty}{Pretty-print the model's intermediate 31 | representation. Normally this is not needed and is intended 32 | primarily for development use. Defaults to the value of the 33 | option \code{odin.pretty} or \code{FALSE} otherwise.} 34 | 35 | \item{skip_cache}{Skip odin's cache. This might be useful if the 36 | model appears not to compile when you would expect it to. 37 | Hopefully this will not be needed often. Defaults to the option 38 | \code{odin.skip_cache} or \code{FALSE} otherwise.} 39 | 40 | \item{compiler_warnings}{Previously this attempted detection of 41 | compiler warnings (with some degree of success), but is 42 | currently ignored. This may become supported again in a future 43 | version depending on underlying support in pkgbuild.} 44 | 45 | \item{no_check_unused_equations}{If \code{TRUE}, then don't print 46 | messages about unused variables. Defaults to the option 47 | \code{odin.no_check_unused_equations} or \code{FALSE} otherwise.} 48 | 49 | \item{rewrite_dims}{Logical, indicating if odin should try and 50 | rewrite your model dimensions (if using arrays). If \code{TRUE} then 51 | we replace dimensions known at compile-time with literal 52 | integers, and those known at initialisation with simplified and 53 | shared expressions. You may get less-comprehensible error 54 | messages with this option set to \code{TRUE} because parts of the 55 | model have been effectively evaluated during processing.} 56 | 57 | \item{rewrite_constants}{Logical, indicating if odin should try 58 | and rewrite \emph{all} constant scalars. This is a superset of 59 | \code{rewrite_dims} and may be slow for large models. Doing this will 60 | make your model less debuggable; error messages will reference 61 | expressions that have been extensively rewritten, some variables 62 | will have been removed entirely or merged with other identical 63 | expressions, and the generated code may not be obviously 64 | connected to the original code.} 65 | 66 | \item{debug_enable}{Enable debugging commands in generated code 67 | (currently \code{print()}). If \code{TRUE} then these are generated by 68 | odin targets that support them, and will generally make your 69 | program slower.} 70 | 71 | \item{substitutions}{Optionally, a list of values to substitute 72 | into model specification as constants, even though they are 73 | declared as \code{user()}. This will be most useful in conjunction 74 | with \code{rewrite_dims} to create a copy of your model with 75 | dimensions known at compile time and all loops using literal 76 | integers.} 77 | 78 | \item{options}{Named list of options. If provided, then all other 79 | options are ignored.} 80 | } 81 | \value{ 82 | A list of parameters, of class \code{odin_options} 83 | } 84 | \description{ 85 | For lower-level odin functions \link{odin_parse}, 86 | \link{odin_validate} we only accept a list of options rather 87 | than individually named options. 88 | } 89 | \examples{ 90 | odin_options() 91 | } 92 | -------------------------------------------------------------------------------- /inst/template/odin_c.R: -------------------------------------------------------------------------------- 1 | {{name}}_ <- R6::R6Class( 2 | "odin_model", 3 | cloneable = FALSE, 4 | 5 | private = list( 6 | ptr = NULL, 7 | use_dde = NULL, 8 | 9 | odin = NULL, 10 | variable_order = NULL, 11 | output_order = NULL, 12 | n_out = NULL, 13 | ynames = NULL, 14 | interpolate_t = NULL, 15 | cfuns = {{cfuns}}, 16 | dll = "{{package}}", 17 | user = {{user}}, 18 | 19 | ## This is never called, but is used to ensure that R finds our 20 | ## symbols that we will use from the package; without this they 21 | ## cannot be found by dynamic lookup now that we use the package 22 | ## FFI registration system. 23 | registration = function() { 24 | if (FALSE) { 25 | {{registration}} 26 | } 27 | }, 28 | 29 | ## This only does something in delay models 30 | set_initial = function({{time}}, y, use_dde) { 31 | .Call("{{c$set_initial}}", private$ptr, {{time}}, y, use_dde, 32 | PACKAGE= "{{package}}") 33 | }, 34 | 35 | update_metadata = function() { 36 | meta <- .Call("{{c$metadata}}", private$ptr, 37 | PACKAGE = "{{package}}") 38 | private$variable_order <- meta$variable_order 39 | private$output_order <- meta$output_order 40 | private$n_out <- meta$n_out 41 | private$ynames <- private$odin$make_names( 42 | private$variable_order, private$output_order, {{discrete}}) 43 | private$interpolate_t <- meta$interpolate_t 44 | } 45 | ), 46 | 47 | public = list( 48 | initialize = function(..., user = list(...), use_dde = FALSE, 49 | unused_user_action = NULL) { 50 | private$odin <- asNamespace("odin") 51 | private$ptr <- .Call("{{c$create}}", user, PACKAGE = "{{package}}") 52 | self$set_user(user = user, unused_user_action = unused_user_action) 53 | private$use_dde <- use_dde 54 | private$update_metadata() 55 | }, 56 | 57 | ir = function() { 58 | path_ir <- system.file("odin/{{name}}.json", mustWork = TRUE, 59 | package = "{{package}}") 60 | json <- readLines(path_ir) 61 | class(json) <- "json" 62 | json 63 | }, 64 | 65 | ## Do we need to have the user-settable args here? It would be 66 | ## nice, but that's not super straightforward to do. 67 | set_user = function(..., user = list(...), unused_user_action = NULL) { 68 | private$odin$support_check_user(user, private$user, unused_user_action) 69 | .Call("{{c$set_user}}", private$ptr, user, PACKAGE = "{{package}}") 70 | private$update_metadata() 71 | }, 72 | 73 | ## This might be time sensitive and, so we can avoid computing 74 | ## it. I wonder if that's an optimisation we should drop for now 75 | ## as it does not seem generally useful. This would bring us 76 | ## closer to the js version which requires that we always pass the 77 | ## time in. 78 | initial = function({{time}}) { 79 | .Call("{{c$initial}}", private$ptr, {{time}}, PACKAGE = "{{package}}") 80 | }, 81 | 82 | rhs = function({{time}}, y) { 83 | .Call("{{c$rhs_r}}", private$ptr, {{time}}, y, PACKAGE = "{{package}}") 84 | }, 85 | 86 | {{rhs}} = function({{time}}, y) { 87 | self$rhs({{time}}, y) 88 | }, 89 | 90 | contents = function() { 91 | .Call("{{c$contents}}", private$ptr, PACKAGE = "{{package}}") 92 | }, 93 | 94 | transform_variables = function(y) { 95 | private$odin$support_transform_variables(y, private) 96 | }, 97 | 98 | engine = function() { 99 | "c" 100 | }, 101 | 102 | run = function({{time}}, y = NULL, ..., use_names = TRUE) { 103 | private$odin${{run}}( 104 | self, private, {{time}}, y, ..., use_names = use_names) 105 | } 106 | )) 107 | 108 | 109 | {{name}} <- function(..., user = list(...), use_dde = FALSE, 110 | unused_user_action = NULL) { 111 | asNamespace("odin")$deprecated_constructor_call("{{name}}") 112 | {{name}}_$new(user = user, use_dde = use_dde, 113 | unused_user_action = unused_user_action) 114 | } 115 | class({{name}}) <- "odin_generator" 116 | attr({{name}}, "generator") <- {{name}}_ 117 | -------------------------------------------------------------------------------- /tests/testthat/helper-odin.R: -------------------------------------------------------------------------------- 1 | on_appveyor <- function() { 2 | identical(Sys.getenv("APPVEYOR"), "True") 3 | } 4 | 5 | 6 | on_travis <- function() { 7 | identical(Sys.getenv("TRAVIS"), "true") 8 | } 9 | 10 | 11 | on_cran <- function() { 12 | !identical(Sys.getenv("NOT_CRAN"), "true") 13 | } 14 | 15 | 16 | on_windows <- function() { 17 | tolower(Sys.info()[["sysname"]]) == "windows" 18 | } 19 | 20 | 21 | on_ci <- function() { 22 | isTRUE(as.logical(Sys.getenv("CI"))) 23 | } 24 | 25 | 26 | skip_on_windows_gha <- function() { 27 | ## There are mystery issues with finding the odin package being 28 | ## tested on windows gha 29 | if (on_ci() && on_windows()) { 30 | testthat::skip("On Windows Github Actions") 31 | } 32 | } 33 | 34 | 35 | validate_ir <- function() { 36 | ## Not worth the faff, and not expected to fail anyway 37 | if (on_cran()) { 38 | FALSE 39 | } 40 | ## Not sure why this is failing, or why, but seems related to V8. I 41 | ## can't replicate easily, valgrind reports no issues, and it was 42 | ## introduced with an update to the jsonvalidate package. 43 | if (on_travis() && getRversion() < numeric_version("3.6.0")) { 44 | FALSE 45 | } 46 | requireNamespace("jsonvalidate", quietly = TRUE) && 47 | requireNamespace("V8", quietly = TRUE) 48 | } 49 | 50 | 51 | options(odin.verbose = FALSE, 52 | odin.validate = validate_ir(), 53 | odin.target = NULL) 54 | 55 | 56 | unload_dlls <- function() { 57 | model_cache_clear() 58 | gc() 59 | } 60 | 61 | 62 | ## access private environment for testing 63 | r6_private <- function(cl) { 64 | environment(cl$initialize)$private 65 | } 66 | 67 | 68 | odin_target_name <- function(using = NULL) { 69 | odin_options(target = using)$target 70 | } 71 | 72 | 73 | skip_for_target <- function(target, reason = NULL, using = NULL) { 74 | if (target == odin_target_name(using)) { 75 | if (is.null(reason)) { 76 | msg <- sprintf("Engine is %s", target) 77 | } else { 78 | msg <- sprintf("Engine is %s (%s)", target, reason) 79 | } 80 | testthat::skip(msg) 81 | } 82 | } 83 | 84 | 85 | with_options <- function(opts, code) { 86 | oo <- options(opts) 87 | on.exit(oo) 88 | force(code) 89 | } 90 | 91 | 92 | model_cache_clear <- function() { 93 | .odin$model_cache_c$clear() 94 | } 95 | 96 | 97 | ## Run a deSolve model 98 | run_model <- function(model, times, parms = NULL, ...) { 99 | y <- model$initial(times[[1L]], parms) 100 | if (isTRUE(model$delay)) { 101 | ## TODO: in theory, this will not work correctly with rk4 & friends 102 | lags <- list(mxhist = 10000) 103 | } else { 104 | lags <- NULL 105 | } 106 | ## TODO: I'm not actually certain that this is the best way of 107 | ## passing parameters. We might need to step through deSolve's ODE 108 | ## initialisation here, but I'm not sure. I think that this 109 | ## approach here will be a touch more general, but some additional 110 | ## work might be needed to deal with globals and the possibilities 111 | ## of nested models; I'll probably handle that with a pointer 112 | ## though. 113 | deSolve::ode(y, times, model$derivs, NULL, lags = lags, ...) 114 | } 115 | 116 | 117 | test_odin_targets <- function() { 118 | if (on_cran()) { 119 | "r" 120 | } else { 121 | has_c <- requireNamespace("pkgbuild", quietly = TRUE) 122 | has_js <- requireNamespace("V8", quietly = TRUE) 123 | c("r", if (has_c) "c", if (has_js) "js") 124 | } 125 | } 126 | 127 | 128 | ## A helper that will run a code block with each target type 129 | test_that_odin <- function(desc, code) { 130 | testthat::skip_if_not_installed("rlang") 131 | targets <- test_odin_targets() 132 | code_enq <- rlang::enquo(code) 133 | for (target in targets) { 134 | opts <- list(odin.target = target, 135 | odin.rewrite_constants = target == "c") 136 | testthat::test_that(sprintf("%s (%s)", desc, target), 137 | withr::with_options(opts, rlang::eval_tidy(code_enq))) 138 | } 139 | } 140 | 141 | 142 | variable_tolerance <- function(mod, default = sqrt(.Machine$double.eps), ...) { 143 | switch(mod$engine(), ..., default) 144 | } 145 | 146 | 147 | local({ 148 | for (f in dir(pattern = "^test-run-")) { 149 | i <- grep("^test_that\\(", readLines(f)) 150 | if (length(i) > 0) { 151 | stop("Found plain test_that at ", 152 | paste(sprintf("%s:%d", f, i), collapse = ", ")) 153 | } 154 | } 155 | }) 156 | -------------------------------------------------------------------------------- /R/generate_c_sexp.R: -------------------------------------------------------------------------------- 1 | generate_c_sexp <- function(x, data, meta, supported) { 2 | if (is.recursive(x)) { 3 | fn <- x[[1L]] 4 | args <- x[-1L] 5 | n <- length(args) 6 | values <- vcapply(args, generate_c_sexp, data, meta, supported) 7 | 8 | if (fn == "(") { 9 | ret <- sprintf("(%s)", values[[1]]) 10 | } else if (fn == "[") { 11 | pos <- c_array_access(args[[1L]], args[-1], data, meta, supported) 12 | ret <- sprintf("%s[%s]", values[[1L]], pos) 13 | } else if (fn == "if") { 14 | ## NOTE: The ternary operator has very low precendence, so I'm 15 | ## going to agressively parenthesise it. This is strictly not 16 | ## needed when this expression is the only element of `expr` but 17 | ## that's hard to detect so we'll tolerate a few additional 18 | ## parens for now. 19 | ret <- sprintf("(%s ? %s : %s)", 20 | values[[1L]], values[[2L]], values[[3L]]) 21 | } else if (n == 2L && fn %in% FUNCTIONS_INFIX) { 22 | fmt <- switch(fn, 23 | "/" = "%s %s (double) %s", 24 | "^" = "%s%s%s", 25 | "%s %s %s") 26 | ret <- sprintf(fmt, values[[1]], fn, values[[2]]) 27 | } else if (fn == "length") { 28 | ret <- generate_c_sexp(data$elements[[args[[1L]]]]$dimnames$length, 29 | data, meta, supported) 30 | } else if (fn == "dim") { 31 | args[[1]] <- sub(sprintf("^%s->", INTERNAL), "", args[[1]]) 32 | dim <- data$elements[[args[[1L]]]]$dimnames$dim[[args[[2]]]] 33 | ret <- generate_c_sexp(dim, data, meta, supported) 34 | } else if (fn %in% c("norm_rand", "unif_rand", "exp_rand")) { 35 | ret <- sprintf("%s(%s)", fn, paste(values, collapse = ", ")) 36 | } else if (fn == "log" && length(values) == 2L) { 37 | ret <- sprintf("(log(%s) / log(%s))", values[[1L]], values[[2L]]) 38 | } else if (fn == "round") { 39 | ## ensures same rounding behaviour of 0.5 as R: 40 | digits <- if (length(values) == 2L) values[[2L]] else 0 41 | ret <- sprintf("fround(%s, %s)", values[[1L]], digits) 42 | } else if (fn == "min" || fn == "max") { 43 | ret <- c_fold_call(paste0("f", fn), values) 44 | } else if (fn == "sum" || fn == "odin_sum") { 45 | ret <- generate_c_sexp_sum(args, data, meta, supported) 46 | } else if (fn == "as.integer") { 47 | ret <- sprintf("(int) (%s)", values[[1L]]) 48 | } else if (fn == "as.numeric") { 49 | ret <- sprintf("(double) (%s)", values[[1L]]) 50 | } else { 51 | if (fn == "rbinom") { 52 | ## This is a little extreme but is useful in at least some 53 | ## cases (and I don't imagine that returning NaN will be 54 | ## useful most of the time). 55 | values[[1L]] <- sprintf("round(%s)", values[[1L]]) 56 | } 57 | if (fn == "rexp") { 58 | values[[1L]] <- sprintf("1 / (double) %s", values[[1L]]) 59 | } 60 | if (any(names(FUNCTIONS_RENAME) == fn)) { 61 | fn <- FUNCTIONS_RENAME[[fn]] 62 | } else if (any(FUNCTIONS_REWRITE_RF == fn)) { 63 | fn <- paste0("Rf_", fn) 64 | } else if (!any(c(names(FUNCTIONS), supported) == fn)) { 65 | stop(sprintf("unsupported function '%s' [odin bug]", fn)) # nocov 66 | } 67 | ret <- sprintf("%s(%s)", fn, paste(values, collapse = ", ")) 68 | } 69 | ret 70 | } else if (is.character(x)) { 71 | location <- data$elements[[x]]$location 72 | if (!is.null(location) && location == "internal") { 73 | sprintf("%s->%s", meta$internal, x) 74 | } else { 75 | x 76 | } 77 | } else if (is.numeric(x)) { 78 | deparse(x, control = "digits17") 79 | } 80 | } 81 | 82 | 83 | generate_c_sexp_sum <- function(args, data, meta, supported) { 84 | target <- generate_c_sexp(args[[1]], data, meta, supported) 85 | data_info <- data$elements[[sub(sprintf("^%s->", INTERNAL), "", args[[1]])]] 86 | type <- data_info$storage_type 87 | if (length(args) == 1L) { 88 | fn <- if (type == "int") "odin_isum1" else "odin_sum1" 89 | len <- generate_c_sexp(data_info$dimnames$length, data, meta, supported) 90 | sprintf("%s(%s, 0, %s)", fn, target, len) 91 | } else { 92 | if (type == "int") { 93 | stop("Partial integer sums not yet supported") 94 | } 95 | i <- seq(2, length(args), by = 2) 96 | 97 | all_args <- c(args, as.list(data_info$dimnames$mult[-1])) 98 | values <- character(length(all_args)) 99 | values[i] <- vcapply(all_args[i], c_minus_1, FALSE, data, meta, supported) 100 | values[-i] <- vcapply(all_args[-i], generate_c_sexp, data, meta, supported) 101 | arg_str <- paste(values, collapse = ", ") 102 | 103 | sprintf_safe("odin_sum%d(%s)", length(i), arg_str) 104 | } 105 | } 106 | -------------------------------------------------------------------------------- /R/odin_options.R: -------------------------------------------------------------------------------- 1 | ##' For lower-level odin functions [odin::odin_parse], 2 | ##' [odin::odin_validate] we only accept a list of options rather 3 | ##' than individually named options. 4 | ##' 5 | ##' @title Odin options 6 | ##' 7 | ##' @inheritParams odin 8 | ##' 9 | ##' @param rewrite_dims Logical, indicating if odin should try and 10 | ##' rewrite your model dimensions (if using arrays). If `TRUE` then 11 | ##' we replace dimensions known at compile-time with literal 12 | ##' integers, and those known at initialisation with simplified and 13 | ##' shared expressions. You may get less-comprehensible error 14 | ##' messages with this option set to `TRUE` because parts of the 15 | ##' model have been effectively evaluated during processing. 16 | ##' 17 | ##' @param rewrite_constants Logical, indicating if odin should try 18 | ##' and rewrite *all* constant scalars. This is a superset of 19 | ##' `rewrite_dims` and may be slow for large models. Doing this will 20 | ##' make your model less debuggable; error messages will reference 21 | ##' expressions that have been extensively rewritten, some variables 22 | ##' will have been removed entirely or merged with other identical 23 | ##' expressions, and the generated code may not be obviously 24 | ##' connected to the original code. 25 | ##' 26 | ##' @param substitutions Optionally, a list of values to substitute 27 | ##' into model specification as constants, even though they are 28 | ##' declared as `user()`. This will be most useful in conjunction 29 | ##' with `rewrite_dims` to create a copy of your model with 30 | ##' dimensions known at compile time and all loops using literal 31 | ##' integers. 32 | ##' 33 | ##' @return A list of parameters, of class `odin_options` 34 | ##' 35 | ##' @export 36 | ##' @examples 37 | ##' odin_options() 38 | odin_options <- function(verbose = NULL, target = NULL, workdir = NULL, 39 | validate = NULL, pretty = NULL, skip_cache = NULL, 40 | compiler_warnings = NULL, 41 | no_check_unused_equations = NULL, 42 | rewrite_dims = NULL, rewrite_constants = NULL, 43 | debug_enable = NULL, 44 | substitutions = NULL, options = NULL) { 45 | default_target <- 46 | if (is.null(target) && !can_compile(verbose = FALSE)) "r" else "c" 47 | defaults <- list( 48 | validate = FALSE, 49 | verbose = TRUE, 50 | target = default_target, 51 | workdir = tempfile(), 52 | pretty = FALSE, 53 | skip_cache = FALSE, 54 | rewrite_dims = FALSE, 55 | rewrite_constants = FALSE, 56 | substitutions = NULL, 57 | debug_enable = FALSE, 58 | no_check_unused_equations = FALSE, 59 | compiler_warnings = FALSE) 60 | if (is.null(options)) { 61 | options <- list( 62 | validate = assert_scalar_logical_or_null(validate), 63 | verbose = assert_scalar_logical_or_null(verbose), 64 | target = target, 65 | pretty = assert_scalar_logical_or_null(pretty), 66 | workdir = workdir, 67 | skip_cache = assert_scalar_logical_or_null(skip_cache), 68 | rewrite_dims = assert_scalar_logical_or_null(rewrite_dims), 69 | rewrite_constants = assert_scalar_logical_or_null(rewrite_constants), 70 | substitutions = check_substitutions(substitutions), 71 | debug_enable = assert_scalar_logical_or_null(debug_enable), 72 | no_check_unused_equations = 73 | assert_scalar_logical_or_null(no_check_unused_equations), 74 | compiler_warnings = assert_scalar_logical_or_null(compiler_warnings)) 75 | } 76 | stopifnot(all(names(defaults) %in% names(options))) 77 | 78 | for (i in names(defaults)) { 79 | if (is.null(options[[i]]) && i != "substitutions") { 80 | options[[i]] <- getOption(paste0("odin.", i), defaults[[i]]) 81 | } 82 | } 83 | 84 | if (is.null(options$read_include)) { 85 | options$read_include <- switch( 86 | options$target, 87 | c = read_include_c, 88 | r = read_include_r, 89 | js = read_include_js, 90 | read_include_unsupported(options$target)) 91 | } 92 | 93 | class(options) <- "odin_options" 94 | options 95 | } 96 | 97 | 98 | check_substitutions <- function(substitutions) { 99 | if (is.null(substitutions)) { 100 | return(NULL) 101 | } 102 | assert_named(substitutions, TRUE) 103 | assert_is(substitutions, "list") 104 | ok <- vlapply(substitutions, function(x) { 105 | is.numeric(x) && length(x) == 1L 106 | }) 107 | if (any(!ok)) { 108 | stop("Invalid entry in substitutions: ", 109 | paste(squote(names_if(!ok)), collapse = ", ")) 110 | } 111 | substitutions 112 | } 113 | 114 | 115 | read_include_js <- function(...) { 116 | ## Fix this around mrc-2027, probably 117 | stop("config(include) is not yet supported with JavaScript") 118 | } 119 | -------------------------------------------------------------------------------- /tests/testthat/test-parse2-debug.R: -------------------------------------------------------------------------------- 1 | test_that("Can parse glue expressions from a string", { 2 | expect_equal(debug_parse_string("{a}"), "a") 3 | expect_equal(debug_parse_string("a"), character(0)) 4 | expect_equal(debug_parse_string("{a} {b} {c}"), c("a", "b", "c")) 5 | }) 6 | 7 | 8 | test_that("Can re-substitute values into a string", { 9 | expect_equal(debug_substitute_string("{a}", 1), "1") 10 | expect_equal(debug_substitute_string("a", character()), "a") 11 | expect_equal(debug_substitute_string("{a} {b} {c}", c("1", "2", "3")), 12 | "1 2 3") 13 | expect_equal(debug_substitute_string("{a;2f} {b} {c}", c("1", "2", "3")), 14 | "1 2 3") 15 | }) 16 | 17 | 18 | test_that("Can parse debug element", { 19 | deps <- function(vars, fns = NULL) { 20 | list(functions = fns %||% character(0), variables = vars) 21 | } 22 | 23 | expect_equal( 24 | debug_parse_element("x"), 25 | list(expr = quote(x), depends = deps("x"), format = NULL)) 26 | expect_equal( 27 | debug_parse_element("x; f"), 28 | list(expr = quote(x), depends = deps("x"), format = "f")) 29 | expect_equal( 30 | debug_parse_element("x + y; f"), 31 | list(expr = quote(x + y), depends = deps(c("x", "y"), "+"), format = "f")) 32 | }) 33 | 34 | 35 | test_that("Can process print call", { 36 | src <- letters 37 | line <- 5 38 | expect_equal( 39 | debug_parse_print_call(list("str"), line, letters), 40 | list(type = "print", expr = "str", when = NULL)) 41 | expect_error( 42 | debug_parse_print_call(list(msg = "str"), line, letters), 43 | "print() expects the first argument to be unnamed", 44 | fixed = TRUE, class = "odin_error") 45 | expect_error( 46 | debug_parse_print_call(10, line, letters), 47 | "print() requires a string argument", 48 | fixed = TRUE, class = "odin_error") 49 | 50 | 51 | expect_equal( 52 | debug_parse_print_call(list("str", when = TRUE), line, letters), 53 | list(type = "print", expr = "str", when = TRUE)) 54 | expect_error( 55 | debug_parse_print_call(list("str", TRUE), line, letters), 56 | "print() expects every argument but the first to be named", 57 | fixed = TRUE, class = "odin_error") 58 | 59 | expect_error( 60 | debug_parse_print_call(list("str", other = TRUE), line, letters), 61 | "Unknown argument to print(): 'other'", 62 | fixed = TRUE, class = "odin_error") 63 | expect_error( 64 | debug_parse_print_call(list("str", a = TRUE, b = FALSE), line, letters), 65 | "Unknown argument to print(): 'a', 'b'", 66 | fixed = TRUE, class = "odin_error") 67 | 68 | expect_error( 69 | debug_parse_print_call(list(), line, letters), 70 | "print() expects at least one argument", 71 | fixed = TRUE, class = "odin_error") 72 | }) 73 | 74 | 75 | test_that("Can process a model with debug printing", { 76 | ir <- odin_parse({ 77 | deriv(x) <- 1 78 | initial(x) <- 0 79 | print("x: {x}") 80 | }) 81 | dat <- ir_deserialise(ir) 82 | expect_true(dat$features$has_debug) 83 | expect_length(dat$debug, 1) 84 | expect_equal(dat$debug[[1]]$type, "print") 85 | expect_equal(dat$debug[[1]]$format, "x: %f") 86 | expect_equal(dat$debug[[1]]$args, list("x")) 87 | expect_equal(dat$debug[[1]]$depends, 88 | list(functions = character(), variables = "x")) 89 | expect_null(dat$debug[[1]]$when) 90 | }) 91 | 92 | 93 | test_that("Require that debug string contains at least one variable", { 94 | expect_error( 95 | odin_parse({ 96 | deriv(x) <- 1 97 | initial(x) <- 0 98 | print("x: %f") 99 | }), 100 | "Invalid print() expression does not reference any values", 101 | fixed = TRUE, class = "odin_error") 102 | }) 103 | 104 | 105 | test_that("Handle parse failure gracefully", { 106 | skip_on_cran() # somewhat platform specific 107 | err <- tryCatch(sprintf("%z"), error = identity) 108 | expect_error( 109 | odin_parse({ 110 | deriv(x) <- 1 111 | initial(x) <- 0 112 | print("x: {x; z}") 113 | }), 114 | paste("Failed to parse debug string 'x; z':", err$msg), 115 | fixed = TRUE, class = "odin_error") 116 | }) 117 | 118 | 119 | test_that("Error if we reference unknown variables in print", { 120 | expect_error( 121 | odin_parse({ 122 | deriv(x) <- 1 123 | initial(x) <- 0 124 | print("x: {z}") 125 | }), 126 | "Unknown variable 'z' in print()", 127 | fixed = TRUE, class = "odin_error") 128 | expect_error( 129 | odin_parse({ 130 | deriv(x) <- 1 131 | initial(x) <- 0 132 | print("{x} - {y} - {z}") 133 | }), 134 | "Unknown variable 'y', 'z' in print()", 135 | fixed = TRUE, class = "odin_error") 136 | }) 137 | 138 | 139 | test_that("prevent currently unknown debug types", { 140 | expect_error( 141 | ir_parse_debug_value(list(type = "assert", source = 1), list(), letters), 142 | "Unknown debug function assert") 143 | }) 144 | --------------------------------------------------------------------------------