diff --git a/CITATION.cff b/CITATION.cff index f986c1fd..f253110a 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -226,24 +226,24 @@ references: year: '2025' doi: 10.32614/CRAN.package.loo - type: software - title: Matrix - abstract: 'Matrix: Sparse and Dense Matrix Classes and Methods' + title: expm + abstract: 'expm: Matrix Exponential, Log, ''etc''' notes: Imports - url: https://R-forge.R-project.org/tracker/?atid=294&group_id=61 - repository: https://CRAN.R-project.org/package=Matrix + url: https://R-forge.R-project.org/tracker/?atid=472&group_id=107 + repository: https://CRAN.R-project.org/package=expm authors: - - family-names: Bates - given-names: Douglas - orcid: https://orcid.org/0000-0001-8316-9503 - family-names: Maechler given-names: Martin - email: mmaechler+Matrix@gmail.com + email: maechler@stat.math.ethz.ch orcid: https://orcid.org/0000-0002-8685-9910 - - family-names: Jagan - given-names: Mikael - orcid: https://orcid.org/0000-0002-3542-2938 + - family-names: Dutang + given-names: Christophe + orcid: https://orcid.org/0000-0001-6732-1501 + - family-names: Goulet + given-names: Vincent + orcid: https://orcid.org/0000-0002-9315-5719 year: '2025' - doi: 10.32614/CRAN.package.Matrix + doi: 10.32614/CRAN.package.expm - type: software title: methods abstract: 'R: A Language and Environment for Statistical Computing' diff --git a/DESCRIPTION b/DESCRIPTION index bc13be46..c9120688 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Imports: glue, graphics, loo, - Matrix, + expm, methods, purrr, Rcpp (>= 0.12.0), @@ -71,7 +71,7 @@ LinkingTo: StanHeaders (>= 2.18.0) VignetteBuilder: knitr -Additional_repositories:https://mc-stan.org/r-packages/ +Additional_repositories: https://mc-stan.org/r-packages/ Biarch: true Config/Needs/website: epiverse-trace/epiversetheme Config/testthat/edition: 3 diff --git a/R/simulate_serosurvey.R b/R/simulate_serosurvey.R index db5a432f..de7f3d1f 100644 --- a/R/simulate_serosurvey.R +++ b/R/simulate_serosurvey.R @@ -334,7 +334,7 @@ prob_seroprev_gen_by_age <- function( probabilities <- vector(length = max_age) for (i in seq_along(probabilities)) { A_sum <- sum_of_A(max_age, max_age - i, construct_A_fun, ...) - Y <- as.matrix(Matrix::expm(A_sum)) %*% initial_conditions + Y <- expm::expm(A_sum) %*% initial_conditions probabilities[i] <- calculate_seroprev_fun(Y) } diff --git a/tests/testthat/test-plot_seromodel.R b/tests/testthat/test-plot_seromodel.R index 22b117b0..d779332f 100644 --- a/tests/testthat/test-plot_seromodel.R +++ b/tests/testthat/test-plot_seromodel.R @@ -13,7 +13,7 @@ serosurvey <- veev2012 suppressWarnings( seromodel_constant <- fit_seromodel( serosurvey = serosurvey, - iter = 500 + iter = 100 ) ) @@ -24,7 +24,7 @@ suppressWarnings( foi_index = get_foi_index(serosurvey, group_size = 20, model_type = "age"), is_seroreversion = TRUE, seroreversion_prior = sf_normal(0, 1e-4), - iter = 200 + iter = 100 ) ) @@ -33,7 +33,7 @@ suppressWarnings( serosurvey = serosurvey, model_type = "time", foi_index = get_foi_index(serosurvey, group_size = 10, model_type = "time"), - iter = 200 + iter = 100 ) ) diff --git a/tests/testthat/test-simulate_serosurvey.R b/tests/testthat/test-simulate_serosurvey.R index a2376b7c..0a7b974b 100644 --- a/tests/testthat/test-simulate_serosurvey.R +++ b/tests/testthat/test-simulate_serosurvey.R @@ -659,202 +659,3 @@ test_that("simulate_serosurvey handles invalid model inputs", { expect_error(simulate_serosurvey("invalid_model", foi_df, survey_features), "model must be one of 'age', 'time', or 'age-time'.") }) - -test_that("prob_seroprev_gen_by_age reduces to time-varying model under - appropriate limits", { - - # simple time-varying FoI model - construct_A <- function(t, tau, lambda) { - A <- matrix(0, ncol = 2, nrow = 2) - A[1, 1] <- -lambda[t] - A[2, 1] <- lambda[t] - A - } - - # determines the sum of seropositive compartments of those still alive - calculate_seroprev_fun <- function(Y) { - Y[2] - } - - # initial conditions in 12D state vector - initial_conditions <- rep(0, 2) - initial_conditions[1] <- 1 - - # random FOIs - lambda <- runif(70, 0, 0.01) - - # solve linear system of ODEs - seropositive_linear_system <- prob_seroprev_gen_by_age( - construct_A, - calculate_seroprev_fun, - initial_conditions, - max_age=length(lambda), - lambda - ) - - foi_df <- data.frame( - year=seq_along(lambda), - foi=lambda - ) - - seropositive_true <- prob_seroprev_by_age( - model = "time", - foi = foi_df, - seroreversion_rate = 0 - ) - - expect_equal(seropositive_true, seropositive_linear_system) - -}) - -test_that("prob_seroprev_gen_by_age reduces to age-varying model under - appropriate limits", { - - # simple age-varying FoI model - construct_A <- function(t, tau, lambda) { - A <- matrix(0, ncol = 2, nrow = 2) - A[1, 1] <- -lambda[t - tau] - A[2, 1] <- lambda[t - tau] - A - } - - # determines the sum of seropositive compartments of those still alive - calculate_seroprev_fun <- function(Y) { - Y[2] - } - - # initial conditions in 12D state vector - initial_conditions <- rep(0, 2) - initial_conditions[1] <- 1 - - # random FOIs - lambda <- runif(70, 0, 0.01) - - # solve linear system of ODEs - seropositive_linear_system <- prob_seroprev_gen_by_age( - construct_A, - calculate_seroprev_fun, - initial_conditions, - max_age=length(lambda), - lambda - ) - - foi_df <- data.frame( - age=seq_along(lambda), - foi=lambda - ) - - seropositive_true <- prob_seroprev_by_age( - model = "age", - foi = foi_df, - seroreversion_rate = 0 - ) - - expect_equal(seropositive_true, seropositive_linear_system) - -}) - -test_that("prob_seroprev_gen_by_age reduces to age- and time-varying model under - appropriate limits", { - - # age- and time-varying FoI model - construct_A <- function(t, tau, u, v) { - A <- matrix(0, ncol = 2, nrow = 2) - u_bar <- u[t - tau] - v_bar <- v[t] - - A[1, 1] <- -u_bar * v_bar - A[2, 1] <- u_bar * v_bar - A - } - - # determines the sum of seropositive compartments of those still alive - calculate_seroprev_fun <- function(Y) { - Y[2] - } - - # initial conditions in 12D state vector - initial_conditions <- rep(0, 2) - initial_conditions[1] <- 1 - - # age and time-varying FOIs - ages <- seq(1, 70, 1) - foi_age <- 2 * dlnorm( - ages, meanlog = 3.5, sdlog = 0.5) - - foi_df_age <- data.frame( - age = ages, - foi = foi_age - ) - - foi_time <- c(rep(0, 30), rep(1, 40)) - foi_df_time <- data.frame( - year = seq(1956, 2025, 1), - foi = foi_time - ) - - u <- foi_df_age$foi - v <- foi_df_time$foi - - # solve linear system of ODEs - seropositive_linear_system <- prob_seroprev_gen_by_age( - construct_A, - calculate_seroprev_fun, - initial_conditions, - max_age = nrow(foi_df_time), - u, - v - ) - - foi_df <- expand.grid( - year=foi_df_time$year, - age=foi_df_age$age - ) |> - dplyr::left_join(foi_df_age, by = "age") |> - dplyr::rename(foi_age = foi) |> - dplyr::left_join(foi_df_time, by = "year") |> - dplyr::rename(foi_time = foi) |> - dplyr::mutate(foi = foi_age * foi_time) |> - dplyr::select(-c("foi_age", "foi_time")) - - seropositive_true <- prob_seroprev_by_age( - model = "age-time", - foi = foi_df, - seroreversion_rate = 0 - ) - - expect_equal(seropositive_true, seropositive_linear_system) - - # simulate survey from age and time FoI - survey_features <- data.frame( - age_min = seq(1, 70, 10), - age_max = seq(10, 70, 10), - n_sample = 1e9) - - serosurvey <- simulate_serosurvey_general( - construct_A, - calculate_seroprev_fun, - initial_conditions, - survey_features, - u, - v - ) |> - dplyr::mutate( - seropositivity = n_seropositive / n_sample - ) - - seropositive_true_age_group <- base::colSums(matrix( - seropositive_linear_system$seropositivity, 10 - )) / 10 - - expect_true( - all( - dplyr::near( - serosurvey$seropositivity, - seropositive_true_age_group, - tol = 1e-4 - ) - ) - ) - -})