From 947274384b4a91689acc9484abdc62ed0ec6408d Mon Sep 17 00:00:00 2001 From: Sebastian Funk Date: Mon, 5 Feb 2024 11:55:25 +0000 Subject: [PATCH 1/4] don't use deprecated fixed option --- R/opts.R | 2 +- tests/testthat/test-dist_spec.R | 17 ++++++++--------- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/R/opts.R b/R/opts.R index 9c02cbaa3..1c0604fdf 100644 --- a/R/opts.R +++ b/R/opts.R @@ -63,8 +63,8 @@ generation_time_opts <- function(dist = dist_spec(mean = 1), ..., if (!("mean" %in% names(dot_options))) { dot_options$mean <- 1 } - dot_options$fixed <- fixed dist <- do.call(dist_spec, dot_options) + if (fixed) dist <- fix_dist(dist) deprecated_options_given <- TRUE } else if (!missing(disease) && !missing(source)) { dist <- get_generation_time(disease, source, max, fixed) diff --git a/tests/testthat/test-dist_spec.R b/tests/testthat/test-dist_spec.R index 00a4343de..3618f2370 100644 --- a/tests/testthat/test-dist_spec.R +++ b/tests/testthat/test-dist_spec.R @@ -29,10 +29,9 @@ test_that("dist_spec returns correct output for uncertain gamma distribution", { }) test_that("dist_spec returns correct output for fixed distribution", { - result <- dist_spec( + result <- fix_dist(dist_spec( mean = 5, mean_sd = 3, sd = 1, max = 19, distribution = "lognormal", - fixed = TRUE - ) + )) expect_equal(dim(result$mean_mean), 0) expect_equal(dim(result$sd_mean), 0) expect_equal(result$fixed, array(1L)) @@ -74,12 +73,12 @@ test_that("+.dist_spec returns correct output for sum of two distributions", { }) test_that("+.dist_spec returns correct output for sum of two fixed distributions", { - lognormal <- dist_spec( - mean = 5, sd = 1, max = 19, distribution = "lognormal", fixed = TRUE - ) - gamma <- dist_spec( - mean = 3, sd = 2, max = 19, distribution = "gamma", fixed = TRUE - ) + lognormal <- fix_dist(dist_spec( + mean = 5, sd = 1, max = 19, distribution = "lognormal" + )) + gamma <- fix_dist(dist_spec( + mean = 3, sd = 2, max = 19, distribution = "gamma" + )) result <- lognormal + gamma expect_equal(dim(result$mean_mean), 0) expect_equal(dim(result$sd_mean), 0) From 6cb63dfe49176b6f631f0d676cb3017e1adede38 Mon Sep 17 00:00:00 2001 From: Sebastian Funk Date: Mon, 5 Feb 2024 11:55:56 +0000 Subject: [PATCH 2/4] use more samples to ensure timeout is hit --- tests/testthat/test-estimate_infections.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-estimate_infections.R b/tests/testthat/test-estimate_infections.R index ecb35a2d6..6a90bb98f 100644 --- a/tests/testthat/test-estimate_infections.R +++ b/tests/testthat/test-estimate_infections.R @@ -86,12 +86,12 @@ test_that("estimate_infections fails as expected when given a very short timeout expect_error(output <- capture.output(suppressMessages( out <- default_estimate_infections( reported_cases, - add_stan = list(future = TRUE, max_execution_time = 1) + add_stan = list(future = TRUE, max_execution_time = 1, samples = 2000) ))), "all chains failed") expect_error(output <- capture.output(suppressMessages( out <- default_estimate_infections( reported_cases, - add_stan = list(future = FALSE, max_execution_time = 1) + add_stan = list(future = FALSE, max_execution_time = 1, samples = 2000) ))), "timed out") }) From 4d665f952725bc95e3c8b1dd29335f32038231a4 Mon Sep 17 00:00:00 2001 From: Sebastian Funk Date: Mon, 5 Feb 2024 11:56:07 +0000 Subject: [PATCH 3/4] update snapshots --- tests/testthat/_snaps/calc_CrI.md | 8 +++++--- tests/testthat/_snaps/calc_CrIs.md | 18 ++++++++++++------ tests/testthat/_snaps/calc_summary_measures.md | 18 ++++++++++++------ tests/testthat/_snaps/calc_summary_stats.md | 10 ++++++---- 4 files changed, 35 insertions(+), 19 deletions(-) diff --git a/tests/testthat/_snaps/calc_CrI.md b/tests/testthat/_snaps/calc_CrI.md index de1002935..e9c6d413b 100644 --- a/tests/testthat/_snaps/calc_CrI.md +++ b/tests/testthat/_snaps/calc_CrI.md @@ -1,12 +1,14 @@ # calc_CrI works as expected with default arguments value CrI + 1: 1.45 lower_90 2: 9.55 upper_90 # calc_CrI works as expected when grouping - type value CrI - 1: car 1.45 lower_90 - 2: car 9.55 upper_90 + type value CrI + + 1: car 1.45 lower_90 + 2: car 9.55 upper_90 diff --git a/tests/testthat/_snaps/calc_CrIs.md b/tests/testthat/_snaps/calc_CrIs.md index a6d8bc44d..beff841fa 100644 --- a/tests/testthat/_snaps/calc_CrIs.md +++ b/tests/testthat/_snaps/calc_CrIs.md @@ -1,15 +1,21 @@ # calc_CrI works as expected with default arguments - . lower_90 lower_50 lower_20 upper_20 upper_50 upper_90 - 1: . 1.45 3.25 4.6 6.4 7.75 9.55 + Key: <.> + . lower_90 lower_50 lower_20 upper_20 upper_50 upper_90 + + 1: . 1.45 3.25 4.6 6.4 7.75 9.55 # calc_CrI works as expected when grouping - type lower_90 lower_50 lower_20 upper_20 upper_50 upper_90 - 1: car 1.45 3.25 4.6 6.4 7.75 9.55 + Key: + type lower_90 lower_50 lower_20 upper_20 upper_50 upper_90 + + 1: car 1.45 3.25 4.6 6.4 7.75 9.55 # calc_CrI works as expected when given a custom CrI list - . lower_95 lower_40 lower_10 upper_10 upper_40 upper_95 - 1: . 1.225 3.7 5.05 5.95 7.3 9.775 + Key: <.> + . lower_95 lower_40 lower_10 upper_10 upper_40 upper_95 + + 1: . 1.225 3.7 5.05 5.95 7.3 9.775 diff --git a/tests/testthat/_snaps/calc_summary_measures.md b/tests/testthat/_snaps/calc_summary_measures.md index f852e7ab0..e96e9546e 100644 --- a/tests/testthat/_snaps/calc_summary_measures.md +++ b/tests/testthat/_snaps/calc_summary_measures.md @@ -1,21 +1,27 @@ # calc_summary_measures works as expected with default arguments - type median mean sd lower_90 lower_50 lower_20 upper_20 upper_50 - 1: car 5.5 5.5 3.02765 1.45 3.25 4.6 6.4 7.75 + type median mean sd lower_90 lower_50 lower_20 upper_20 upper_50 + + 1: car 5.5 5.5 3.02765 1.45 3.25 4.6 6.4 7.75 upper_90 + 1: 9.55 # calc_CrI works as expected when grouping - type median mean sd lower_90 lower_50 lower_20 upper_20 upper_50 - 1: car 5.5 5.5 3.02765 1.45 3.25 4.6 6.4 7.75 + type median mean sd lower_90 lower_50 lower_20 upper_20 upper_50 + + 1: car 5.5 5.5 3.02765 1.45 3.25 4.6 6.4 7.75 upper_90 + 1: 9.55 # calc_CrI works as expected when given a custom CrI list - type median mean sd lower_95 lower_40 lower_10 upper_10 upper_40 - 1: car 5.5 5.5 3.02765 1.225 3.7 5.05 5.95 7.3 + type median mean sd lower_95 lower_40 lower_10 upper_10 upper_40 + + 1: car 5.5 5.5 3.02765 1.225 3.7 5.05 5.95 7.3 upper_95 + 1: 9.775 diff --git a/tests/testthat/_snaps/calc_summary_stats.md b/tests/testthat/_snaps/calc_summary_stats.md index 2bab89871..672a30a7e 100644 --- a/tests/testthat/_snaps/calc_summary_stats.md +++ b/tests/testthat/_snaps/calc_summary_stats.md @@ -1,10 +1,12 @@ # calc_summary_stats works as expected with default arguments - median mean sd - 1: 5.5 5.5 3.02765 + median mean sd + + 1: 5.5 5.5 3.02765 # calc_summary_stats works as expected when grouping - type median mean sd - 1: car 5.5 5.5 3.02765 + type median mean sd + + 1: car 5.5 5.5 3.02765 From 55a644f6c3708bb5f3e69edd6a2ea95554072133 Mon Sep 17 00:00:00 2001 From: Sebastian Funk Date: Mon, 5 Feb 2024 11:58:07 +0000 Subject: [PATCH 4/4] avoid using array-vector arithmetic in dist_skel --- R/dist.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/dist.R b/R/dist.R index 32f0fbe0e..be218d0da 100644 --- a/R/dist.R +++ b/R/dist.R @@ -1403,12 +1403,12 @@ fix_dist <- function(x, strategy = c("mean", "sample")) { ## apply stragey depending on choice if (strategy == "mean") { x <- dist_spec( - mean = x$mean_mean, - sd = x$sd_mean, + mean = c(x$mean_mean), + sd = c(x$sd_mean), mean_sd = 0, sd_sd = 0, distribution = x$dist, - max = x$max + max = c(x$max) ) } else if (strategy == "sample") { lower_bound <- ifelse(x$dist == "gamma", 0, -Inf) @@ -1422,7 +1422,7 @@ fix_dist <- function(x, strategy = c("mean", "sample")) { mean_sd = 0, sd_sd = 0, distribution = x$dist, - max = x$max + max = c(x$max) ) } return(x)