Merge branch 'main' into approximate-inference-vignette

.github/workflows/pkgdown.yaml

@@ -56,7 +56,7 @@ jobs:
 
       - name: Deploy to GitHub pages 🚀
         if: github.event_name != 'pull_request'
-        uses: JamesIves/[email protected].1
+        uses: JamesIves/[email protected].3
         with:
           clean: false
           branch: gh-pages

DESCRIPTION

@@ -4,15 +4,15 @@ Version: 0.0.0.9000
 Authors@R:
   c(person(given = "Sang Woo",
            family = "Park",
-           role = c("aut", "cre"),
+           role = c("aut"),
            email = "[email protected]",
            comment = c(ORCID = "0000-0003-2202-3361")),
     person(given = "Sam Abbott",
            role = c("aut"),
            email = "[email protected]",
            comment = c(ORCID = "0000-0001-8057-8037")),
     person(given = "Adam Howes",
-           role = c("aut"),
+           role = c("aut", "cre"),
            email = "[email protected]",
            comment = c(ORCID = "0000-0003-2386-4031")))
 Description: Understanding and accurately estimating epidemiological delay
@@ -34,10 +34,10 @@ Imports:
     here,
     stats,
     cli,
+    checkmate,
     rstan
 Suggests:
     bookdown,
-    epinowcast,
     testthat (>= 3.0.0),
     readxl,
     janitor,
@@ -48,7 +48,6 @@ Suggests:
 Remotes:
     stan-dev/cmdstanr,
     Rdatatable/data.table,
-    epinowcast/epinowcast,
     paul-buerkner/brms
 Config/Needs/website:
     r-lib/pkgdown,

NAMESPACE

@@ -29,7 +29,6 @@ export(epidist_stan_chunk)
 export(epidist_stancode)
 export(epidist_version_stanvar)
 export(event_to_incidence)
-export(extract_epinowcast_draws)
 export(extract_lognormal_draws)
 export(filter_obs_by_obs_time)
 export(filter_obs_by_ptime)
@@ -46,7 +45,6 @@ export(plot_mean_posterior_pred)
 export(plot_recovery)
 export(plot_relative_recovery)
 export(reverse_obs_at)
-export(sample_epinowcast_model)
 export(sample_model)
 export(simulate_double_censored_pmf)
 export(simulate_exponential_cases)

R/fitting-and-postprocessing.R

@@ -54,76 +54,6 @@ sample_model <- function(model, data, scenario = data.table::data.table(id = 1),
   return(out[])
 }
 
-#' Sample from the posterior of an epinowcast model with additional diagnositics
-#'
-#' @inheritParams sample_model
-#' @family postprocess
-#' @export
-sample_epinowcast_model <- function(
-  model, data, scenario = data.table::data.table(id = 1),
-  diagnostics = TRUE, ...
-) {
-
-  out <- data.table::copy(scenario)
-
-  # Setup failure tolerant model fitting
-  fit_model <- function(model, data, ...) {
-    fit <- epinowcast::enw_model(
-      target_dir = here::here("data", "models")
-    )$sample(data = data, ...)
-    print(fit)
-    return(fit)
-  }
-  safe_fit_model <- purrr::safely(fit_model)
-  fit <- safe_fit_model(model, data, ...)
-
-  if (!is.null(fit$error)) {
-    out[, error := list(fit$error[[1]])]
-    diagnostics <- FALSE
-  }else {
-    out[, fit := list(fit$result)]
-    fit <- fit$result
-  }
-
-  if (diagnostics) {
-    diag <- fit$sampler_diagnostics(format = "df")
-    diagnostics <- data.table(
-      samples = nrow(diag),
-      max_rhat = round(max(
-        fit$summary(
-          variables = NULL, posterior::rhat,
-          .args = list(na.rm = TRUE)
-        )$`posterior::rhat`,
-        na.rm = TRUE
-      ), 0),
-      min_ess_bulk = round(min(
-        fit$summary(
-          variables = NULL, posterior::ess_bulk,
-          .args = list(na.rm = TRUE)
-        )$`posterior::ess_bulk`,
-        na.rm = TRUE
-      ), 2),
-      min_ess_tail = round(min(
-        fit$summary(
-          variables = NULL, posterior::ess_tail,
-          .args = list(na.rm = TRUE)
-        )$`posterior::ess_tail`,
-        na.rm = TRUE
-      ), 0),
-      divergent_transitions = sum(diag$divergent__),
-      per_divergent_transitions = sum(diag$divergent__) / nrow(diag),
-      max_treedepth = max(diag$treedepth__)
-    )
-    diagnostics[, no_at_max_treedepth := sum(diag$treedepth__ == max_treedepth)]
-    diagnostics[, per_at_max_treedepth := no_at_max_treedepth / nrow(diag)]
-    out <- cbind(out, diagnostics)
-
-    timing <- round(max(fit$metadata()$time$total), 1)
-    out[, run_time := timing]
-  }
-  return(out[])
-}
-
 #' Add natural scale summary parameters for a lognormal distribution
 #'
 #' @param dt ...
@@ -182,45 +112,6 @@ extract_lognormal_draws <- function(data, id_vars, from_dt = FALSE) {
   return(draws[])
 }
 
-#' Extract posterior samples for a lognormal epinowcast model
-#'
-#' @inheritParams extract_lognormal_draws
-#' @family postprocess
-#' @autoglobal
-#' @export
-extract_epinowcast_draws <- function(
-  data, id_vars, from_dt = FALSE
-) {
-  if (from_dt) {
-    if (!any(colnames(data) %in% "fit")) {
-      return(id_vars[])
-    }
-    draws <- data$fit[[1]]$draws(
-      variables = c("refp_mean_int[1]", "refp_sd_int[1]"), format = "draws_df"
-    )
-  }else {
-    draws <- data$fit[[1]]$draws(
-      variables = c("refp_mean_int[1]", "refp_sd_int[1]"), format = "draws_df"
-    )
-  }
-
-  draws <- data.table::setDT(draws)
-
-  data.table::setnames(
-    draws, c("refp_mean_int[1]", "refp_sd_int[1]"), c("meanlog", "sdlog"),
-    skip_absent = TRUE
-  )
-  draws <- draws[, list(meanlog, sdlog)]
-  draws <- add_natural_scale_mean_sd(draws)
-
-  if (!missing(id_vars)) {
-    draws <- merge(
-      draws[, id := id_vars$id], id_vars, by = "id"
-    )
-  }
-  return(draws[])
-}
-
 #' Primary event bias correction
 #'
 #' @param draws ...

R/globals.R

@@ -13,9 +13,6 @@ utils::globalVariables(c(
   "sdlog_log", # <extract_lognormal_draws>
   "meanlog", # <extract_lognormal_draws>
   "id", # <extract_lognormal_draws>
-  "meanlog", # <extract_epinowcast_draws>
-  "sdlog", # <extract_epinowcast_draws>
-  "id", # <extract_epinowcast_draws>
   "true_value", # <make_relative_to_truth>
   "value", # <make_relative_to_truth>
   "rel_value", # <make_relative_to_truth>

R/latent_individual.R

@@ -61,11 +61,24 @@ epidist_formula.epidist_latent_individual <- function(data, delay_central = ~ 1,
   return(form)
 }
 
+#' @importFrom rstan lookup
 #' @method epidist_family epidist_latent_individual
 #' @family latent_individual
 #' @export
 epidist_family.epidist_latent_individual <- function(data, family = "lognormal",
                                                      ...) {
+  checkmate::assert_string(family)
+
+  pdf_lookup <- rstan::lookup("pdf")
+  valid_pdfs <- gsub("_lpdf", "", pdf_lookup$StanFunction)
+  if (!family %in% valid_pdfs) {
+    cli::cli_warn(
+      "The provided family {.code family} does not correspond to a valid LPDF
+      function available in rstan. (It is possible [but unlikely] that there is
+      such an LPDF in Stan available via cmdstanr, as rstan is behind Stan.)"
+    )
+  }
+
   brms::custom_family(
     paste0("latent_", family),
     dpars = c("mu", "sigma"),