From 13427fe9c95f338579bf46e212065cd9e9b1a931 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Fri, 20 Feb 2026 15:41:42 +0200 Subject: [PATCH 01/63] proof of concept for posterior_pit --- R/posterior_predict.R | 78 +++++++++++++++++++++++++++++++++---------- 1 file changed, 61 insertions(+), 17 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index a791b718b..cd948f94c 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -82,7 +82,7 @@ posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, - ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, + ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, type = "r", cores = NULL, ... ) { cl <- match.call() @@ -93,11 +93,11 @@ posterior_predict.brmsfit <- function( object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... + ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, type = type, ... ) posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE + negative_rt = negative_rt, cores = cores, summary = FALSE, type = type ) } @@ -119,7 +119,7 @@ posterior_predict.mvbrmsprep <- function(object, ...) { posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, summary = FALSE, robust = FALSE, probs = c(0.025, 0.975), - cores = NULL, ...) { + cores = NULL, type = "r", ...) { summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) if (is.customfamily(object$family)) { @@ -136,7 +136,7 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, pp_fun <- paste0("posterior_predict_", object$family$fun) pp_fun <- get(pp_fun, asNamespace("brms")) N <- choose_N(object) - out <- plapply(seq_len(N), pp_fun, .cores = cores, prep = object, ...) + out <- plapply(seq_len(N), pp_fun, .cores = cores, prep = object, type = type, ...) if (grepl("_mv$", object$family$fun)) { out <- do_call(abind, c(out, along = 3)) out <- aperm(out, perm = c(1, 3, 2)) @@ -309,28 +309,44 @@ validate_pp_method <- function(method) { # @param ... ignored arguments # @param A vector of length prep$ndraws containing draws # from the posterior predictive distribution -posterior_predict_gaussian <- function(i, prep, ntrys = 5, ...) { +posterior_predict_gaussian <- function(i, prep, ntrys = 5, type = "r", ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) - rcontinuous( - n = prep$ndraws, dist = "norm", - mean = mu, sd = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + switch(type, + r = rcontinuous( + n = prep$ndraws, dist = "norm", + mean = mu, sd = sigma, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ), + p = pcontinuous( + n = prep$ndraws, dist = "norm", + q = prep$data$Y[i], mean = mu, sd = sigma, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) ) } -posterior_predict_student <- function(i, prep, ntrys = 5, ...) { +posterior_predict_student <- function(i, prep, ntrys = 5, type = "r", ...) { nu <- get_dpar(prep, "nu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) - rcontinuous( - n = prep$ndraws, dist = "student_t", - df = nu, mu = mu, sigma = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + switch(type, + r = rcontinuous( + n = prep$ndraws, dist = "student_t", + df = nu, mu = mu, sigma = sigma, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ), + p = pcontinuous( + n = prep$ndraws, dist = "student_t", + q = prep$data$Y[i], df = nu, mu = mu, sigma = sigma, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) ) } @@ -1002,6 +1018,34 @@ rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } +pcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { + args <- list(...) + if (is.null(lb) && is.null(ub)) { + # sample as usual + pdist <- paste0("p", dist) + out <- do_call(pdist, c(list(n), args)) + } else { + error("not implemented yet") + # sample from truncated distribution + pdist <- paste0("p", dist) + qdist <- paste0("q", dist) + if (!exists(pdist, mode = "function") || !exists(qdist, mode = "function")) { + # use rejection sampling as CDF or quantile function are not available + out <- rdiscrete(n, dist, ..., lb = lb, ub = ub, ntrys = ntrys) + } else { + if (is.null(lb)) lb <- -Inf + if (is.null(ub)) ub <- Inf + plb <- do_call(pdist, c(list(lb), args)) + pub <- do_call(pdist, c(list(ub), args)) + out <- runif(n, min = plb, max = pub) + out <- do_call(qdist, c(list(out), args)) + # infinite values may be caused by numerical imprecision + out[out %in% c(-Inf, Inf)] <- NA + } + } + out +} + # random numbers from (possibly truncated) discrete distributions # currently rejection sampling is used for truncated distributions # @param n number of random values to generate From 1b046ebb0536c8b1a0ce23ffbfb993ad508222b7 Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 08:02:38 +0200 Subject: [PATCH 02/63] switch 'type' to 'output'; add wrapper function --- R/posterior_predict.R | 79 ++++++++++++++++++++++++------------------- 1 file changed, 45 insertions(+), 34 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index cd948f94c..483734201 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -82,7 +82,7 @@ posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, - ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, type = "r", + ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, output = "random", cores = NULL, ... ) { cl <- match.call() @@ -93,11 +93,11 @@ posterior_predict.brmsfit <- function( object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, type = type, ... + ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE, type = type + negative_rt = negative_rt, cores = cores, summary = FALSE, output = output ) } @@ -119,7 +119,7 @@ posterior_predict.mvbrmsprep <- function(object, ...) { posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, summary = FALSE, robust = FALSE, probs = c(0.025, 0.975), - cores = NULL, type = "r", ...) { + cores = NULL, ...) { summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) if (is.customfamily(object$family)) { @@ -136,7 +136,7 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, pp_fun <- paste0("posterior_predict_", object$family$fun) pp_fun <- get(pp_fun, asNamespace("brms")) N <- choose_N(object) - out <- plapply(seq_len(N), pp_fun, .cores = cores, prep = object, type = type, ...) + out <- plapply(seq_len(N), pp_fun, .cores = cores, prep = object, output = output, ...) if (grepl("_mv$", object$family$fun)) { out <- do_call(abind, c(out, along = 3)) out <- aperm(out, perm = c(1, 3, 2)) @@ -301,52 +301,63 @@ validate_pp_method <- function(method) { method } +# Helper function to predict continuous distributions +# @param output "probability" or "random" +# @param prep A named list returned by prepare_predictions containing +# all required data and posterior draws +# @param i index of the observation for which to compute pp values +# @param dist name of the distribution +# @param ntrys number of trys in rejection sampling for truncated models +# @param ... additional arguments passed to the distribution functions +# @return a vector of draws from the distribution +.predict_continuous_helper <- function(output, prep, i, dist, ntrys, ...) { + lb <- prep$data$lb[i] + ub <- prep$data$ub[i] + + switch(output, + "probability" = { + q <- prep$data$Y[i] + pcontinuous( + q = q, dist = dist, lb = lb, ub = ub, ntrys = ntrys, + ndraws = prep$ndraws, ... + ) + }, + "random" = { + rcontinuous( + n = prep$ndraws, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + ) + } + ) +} + # ------------------- family specific posterior_predict methods --------------------- # All posterior_predict_ functions have the same arguments structure -# @param i index of the observatio for which to compute pp values +# @param i index of the observation for which to compute pp values # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws # @param ... ignored arguments # @param A vector of length prep$ndraws containing draws # from the posterior predictive distribution -posterior_predict_gaussian <- function(i, prep, ntrys = 5, type = "r", ...) { +posterior_predict_gaussian <- function(i, prep, ntrys = 5, output = "random", ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) - switch(type, - r = rcontinuous( - n = prep$ndraws, dist = "norm", - mean = mu, sd = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ), - p = pcontinuous( - n = prep$ndraws, dist = "norm", - q = prep$data$Y[i], mean = mu, sd = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) + + .predict_continuous_helper( + output = output, prep = prep, i = i, ntrys = ntrys, + dist = "norm", mean = mu, sd = sigma ) } -posterior_predict_student <- function(i, prep, ntrys = 5, type = "r", ...) { +posterior_predict_student <- function(i, prep, ntrys = 5, output = "random", ...) { nu <- get_dpar(prep, "nu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) - switch(type, - r = rcontinuous( - n = prep$ndraws, dist = "student_t", - df = nu, mu = mu, sigma = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ), - p = pcontinuous( - n = prep$ndraws, dist = "student_t", - q = prep$data$Y[i], df = nu, mu = mu, sigma = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) + + .predict_continuous_helper( + output = output, prep = prep, i = i, ntrys = ntrys, + dist = "student_t", df = nu, mu = mu, sigma = sigma ) } From 51026133530a015be8f23420855a4e042707de1b Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 09:46:09 +0200 Subject: [PATCH 03/63] add test for posterior_predict with output arg --- tests/testthat/tests.posterior_predict.R | 26 ++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 533797b15..3e3c9c9d3 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -439,3 +439,29 @@ test_that("posterior_predict_custom runs without errors", { } expect_equal(length(brms:::posterior_predict_custom(sample(1:nobs, 1), prep)), ns) }) + +test_that("posterior_predict for location shift models runs with 'output' argument without error", { + ns <- 30 + nobs <- 10 + prep <- structure(list(ndraws = ns), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rchisq(ns, 3), nu = rgamma(ns, 4) + ) + prep$data <- list(Y = rpred) + i <- sample(nobs, 1) + + pnorm(prep$data$Y[i]) + + # probability + rpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") + expect_equal(length(rpred), ns) + + qpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") + + expect_equal(length(qpred), ns) + + pred <- brms:::posterior_predict_student(i, prep = prep) + expect_equal(length(pred), ns) +}) + From bbfd28cf73be6f2d9d74f2351efaf83e2040d19b Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 13:02:19 +0200 Subject: [PATCH 04/63] fix 'probability' method for posterior_predict --- R/posterior_predict.R | 68 ++++++++++++++++++++++--------------------- 1 file changed, 35 insertions(+), 33 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 483734201..a7c9c522a 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -301,35 +301,6 @@ validate_pp_method <- function(method) { method } -# Helper function to predict continuous distributions -# @param output "probability" or "random" -# @param prep A named list returned by prepare_predictions containing -# all required data and posterior draws -# @param i index of the observation for which to compute pp values -# @param dist name of the distribution -# @param ntrys number of trys in rejection sampling for truncated models -# @param ... additional arguments passed to the distribution functions -# @return a vector of draws from the distribution -.predict_continuous_helper <- function(output, prep, i, dist, ntrys, ...) { - lb <- prep$data$lb[i] - ub <- prep$data$ub[i] - - switch(output, - "probability" = { - q <- prep$data$Y[i] - pcontinuous( - q = q, dist = dist, lb = lb, ub = ub, ntrys = ntrys, - ndraws = prep$ndraws, ... - ) - }, - "random" = { - rcontinuous( - n = prep$ndraws, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... - ) - } - ) -} - # ------------------- family specific posterior_predict methods --------------------- # All posterior_predict_ functions have the same arguments structure # @param i index of the observation for which to compute pp values @@ -345,7 +316,7 @@ posterior_predict_gaussian <- function(i, prep, ntrys = 5, output = "random", .. .predict_continuous_helper( output = output, prep = prep, i = i, ntrys = ntrys, - dist = "norm", mean = mu, sd = sigma + dist = "norm", mean = mu, sd = sigma, ... ) } @@ -357,7 +328,7 @@ posterior_predict_student <- function(i, prep, ntrys = 5, output = "random", ... .predict_continuous_helper( output = output, prep = prep, i = i, ntrys = ntrys, - dist = "student_t", df = nu, mu = mu, sigma = sigma + dist = "student_t", df = nu, mu = mu, sigma = sigma, ... ) } @@ -1029,12 +1000,12 @@ rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } -pcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { +pcontinuous <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { args <- list(...) if (is.null(lb) && is.null(ub)) { # sample as usual pdist <- paste0("p", dist) - out <- do_call(pdist, c(list(n), args)) + out <- do_call(pdist, c(list(q), args)) } else { error("not implemented yet") # sample from truncated distribution @@ -1140,3 +1111,34 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { } round(x) } + +# predict random numbers or probability values from continuous distributions +# @param output "probability" or "random" +# @param prep A named list returned by prepare_predictions containing +# all required data and posterior draws +# @param i index of the observation for which to compute pp values +# @param dist name of the distribution +# @param ntrys number of trys in rejection sampling for truncated models +# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] +# @param ... additional arguments passed to the distribution functions +# @return a vector of draws +.predict_continuous_helper <- function(output, prep, i, dist, ntrys, q = NULL, ...) { + lb <- prep$data$lb[i] + ub <- prep$data$ub[i] + + switch(output, + "probability" = { + if (is.null(q)) { + q <- prep$data$Y[i] + } + pcontinuous( + q = prep$data$Y[i], dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + ) + }, + "random" = { + rcontinuous( + n = prep$ndraws, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + ) + } + ) +} From 780ad34a8fdaf07db11fe7152a1f3f753e73542b Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 13:02:40 +0200 Subject: [PATCH 05/63] add test for posterior_predict_gaussian --- tests/testthat/tests.posterior_predict.R | 33 +++++++++++------------- 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 3e3c9c9d3..9e2798647 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -440,28 +440,25 @@ test_that("posterior_predict_custom runs without errors", { expect_equal(length(brms:::posterior_predict_custom(sample(1:nobs, 1), prep)), ns) }) -test_that("posterior_predict for location shift models runs with 'output' argument without error", { - ns <- 30 - nobs <- 10 - prep <- structure(list(ndraws = ns), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rchisq(ns, 3), nu = rgamma(ns, 4) - ) - prep$data <- list(Y = rpred) - i <- sample(nobs, 1) - - pnorm(prep$data$Y[i]) +test_that("posterior_predict_gaussian runs with various 'output' values without error", { + fit <- rename_pars(brms:::brmsfit_example3) + prep <- brms::prepare_predictions(fit) + model_fit <- fit$fit@sim + S <- model_fit$chains * (model_fit$iter - model_fit$warmup) + i <- 1 # probability rpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") - expect_equal(length(rpred), ns) + expect_equal(length(rpred), S) - qpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") + # compute PIT values (q = prep$data$Y[i]) + PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") + expect_equal(length(PITs), S) + expect_true(all(PITs >= 0 & PITs <= 1)) - expect_equal(length(qpred), ns) - - pred <- brms:::posterior_predict_student(i, prep = prep) - expect_equal(length(pred), ns) + # compute cdf based on custom 'q' + qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability") + expect_equal(length(qpred), S) + expect_true(all(qpred >= 0 & qpred <= 1)) }) From 3106b93188979dcafe78267d3ad210c4ad84db91 Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 14:39:57 +0200 Subject: [PATCH 06/63] fix setting of q --- R/posterior_predict.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index a7c9c522a..e7de15c0f 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1132,7 +1132,7 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { q <- prep$data$Y[i] } pcontinuous( - q = prep$data$Y[i], dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + q = q, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... ) }, "random" = { From 232cf1d4a9c730b136959d464f745ab2736eb94b Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 14:57:24 +0200 Subject: [PATCH 07/63] add failing test if q is assigned wrongly --- tests/testthat/tests.posterior_predict.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 9e2798647..b5fe728b0 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -459,6 +459,7 @@ test_that("posterior_predict_gaussian runs with various 'output' values without # compute cdf based on custom 'q' qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred), S) + expect_false(all(PITs == qpred)) expect_true(all(qpred >= 0 & qpred <= 1)) }) From a898b24c202d516bde962284ddfe13657538d5bd Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 22:08:03 +0200 Subject: [PATCH 08/63] add cdf for truncated cont. distr --- R/posterior_predict.R | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index e7de15c0f..5e4e080a9 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1002,28 +1002,26 @@ rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { pcontinuous <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { args <- list(...) + pdist <- paste0("p", dist) + if (is.null(lb) && is.null(ub)) { - # sample as usual - pdist <- paste0("p", dist) + # non-truncated case out <- do_call(pdist, c(list(q), args)) } else { - error("not implemented yet") - # sample from truncated distribution - pdist <- paste0("p", dist) - qdist <- paste0("q", dist) - if (!exists(pdist, mode = "function") || !exists(qdist, mode = "function")) { - # use rejection sampling as CDF or quantile function are not available - out <- rdiscrete(n, dist, ..., lb = lb, ub = ub, ntrys = ntrys) - } else { - if (is.null(lb)) lb <- -Inf - if (is.null(ub)) ub <- Inf - plb <- do_call(pdist, c(list(lb), args)) - pub <- do_call(pdist, c(list(ub), args)) - out <- runif(n, min = plb, max = pub) - out <- do_call(qdist, c(list(out), args)) - # infinite values may be caused by numerical imprecision - out[out %in% c(-Inf, Inf)] <- NA - } + # truncated case + F_q <- do_call(pdist, c(list(q), args)) + F_lb <- do_call(pdist, c(list(lb), args)) + F_ub <- do_call(pdist, c(list(ub), args)) + + scale_factor <- F_ub - F_lb + + # compute truncated CDF: (F(q) - F(lb)) / (F(ub) - F(lb)) + out <- dplyr::case_when( + q < lb ~ 0, + q > ub ~ 1, + (F_ub - F_lb) == 0 ~ 1, + TRUE ~ (F_q - F_lb) / (F_ub - F_lb) + ) } out } From 94cb02aab2a144557aad0fb66b8ee2e415a2c0a5 Mon Sep 17 00:00:00 2001 From: florence-bockting Date: Fri, 27 Feb 2026 22:08:33 +0200 Subject: [PATCH 09/63] add test for truncated posterior_predict_gaussian --- tests/testthat/tests.posterior_predict.R | 34 ++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index b5fe728b0..cec8853cb 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -463,3 +463,37 @@ test_that("posterior_predict_gaussian runs with various 'output' values without expect_true(all(qpred >= 0 & qpred <= 1)) }) +test_that("truncated posterior_predict_gaussian runs with various 'output' values without error", { + skip_if_not_installed("truncnorm") + set.seed(1335) + ns <- 30 + nobs <- 15 + i <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rchisq(ns, 3) + ) + prep$data <- list( + Y = rnorm(nobs), + lb = replicate(nobs, 0), + ub = replicate(nobs, 10) + ) + + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + sigma <- add_sigma_se(sigma, prep, i = i) + + # compute cdf for truncated distribution + obs_trunc_PITs <- brms:::posterior_predict_gaussian( + i, prep = prep, output = "probability") + expected_PITs <- truncnorm::ptruncnorm( + q = prep$data$Y[i], a = prep$data$lb[i], + b = prep$data$ub[i], mean = mu, sd = sigma + ) + expect_equal(obs_trunc_PITs, expected_PITs) + + # take random draws from a truncated distribution + rpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") + expect_true(all(rpred >= prep$data$lb[i] & rpred <= prep$data$ub[i])) +}) \ No newline at end of file From 18667c19843557024c8db4b00b15f0766610824d Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Sat, 28 Feb 2026 12:50:26 +0200 Subject: [PATCH 10/63] add test for posterior_predict_student --- tests/testthat/tests.posterior_predict.R | 63 ++++++++++++++++++++---- 1 file changed, 53 insertions(+), 10 deletions(-) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index cec8853cb..44d7236e0 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -447,7 +447,7 @@ test_that("posterior_predict_gaussian runs with various 'output' values without S <- model_fit$chains * (model_fit$iter - model_fit$warmup) i <- 1 - # probability + # random draws from Gaussian rpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") expect_equal(length(rpred), S) @@ -480,20 +480,63 @@ test_that("truncated posterior_predict_gaussian runs with various 'output' value ub = replicate(nobs, 10) ) - mu <- get_dpar(prep, "mu", i = i) - sigma <- get_dpar(prep, "sigma", i = i) - sigma <- add_sigma_se(sigma, prep, i = i) + mu <- brms:::get_dpar(prep, "mu", i = i) + sigma <- brms:::get_dpar(prep, "sigma", i = i) + sigma <- brms:::add_sigma_se(sigma, prep, i = i) # compute cdf for truncated distribution - obs_trunc_PITs <- brms:::posterior_predict_gaussian( - i, prep = prep, output = "probability") - expected_PITs <- truncnorm::ptruncnorm( - q = prep$data$Y[i], a = prep$data$lb[i], - b = prep$data$ub[i], mean = mu, sd = sigma - ) + obs_trunc_PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") + expected_PITs <- truncnorm::ptruncnorm(q = prep$data$Y[i], a = prep$data$lb[i], + b = prep$data$ub[i], mean = mu, sd = sigma) expect_equal(obs_trunc_PITs, expected_PITs) # take random draws from a truncated distribution rpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") expect_true(all(rpred >= prep$data$lb[i] & rpred <= prep$data$ub[i])) +}) + +test_that("posterior_predict_student runs with various 'output' values without error", { + set.seed(1334) + ns <- 30 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rchisq(ns, 3), + nu = rgamma(ns, 4) + ) + prep$data <- list(Y = rstudent_t(nobs, df = 3)) + i <- 8 + + # random draws from non-truncated t + rpred <- brms:::posterior_predict_student(i, prep = prep, output = "random") + expect_equal(length(rpred), ns) + + # compute PIT values (q = prep$data$Y[i]) + PITs <- brms:::posterior_predict_student(i, prep = prep, output = "probability") + expect_equal(length(PITs), ns) + expect_true(all(PITs >= 0 & PITs <= 1)) + + # compute cdf based on custom 'q' + qpred <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") + expect_equal(length(qpred), ns) + expect_false(all(PITs == qpred)) + expect_true(all(qpred >= 0 & qpred <= 1)) + + prep$data$lb <- replicate(nobs, 0) + prep$data$ub <- replicate(nobs, 30) + + # random draws from truncated t + rpred <- brms:::posterior_predict_student(i, prep = prep, output = "random") + expect_true(all(rpred >= prep$data$lb[i] & rpred <= prep$data$ub[i])) + + # compute PIT values for truncated t (q = prep$data$Y[i]) + PITs_trunc <- brms:::posterior_predict_student(i, prep = prep, output = "probability") + expect_equal(length(PITs_trunc), ns) + expect_false(all(PITs == PITs_trunc)) + + # compute cdf for truncated t based on custom 'q' + qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") + expect_equal(length(qpred_trunc), ns) + expect_false(all(qpred == qpred_trunc)) }) \ No newline at end of file From 2849ae362300cf3c552c8131364d23dff1f894b1 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Sat, 28 Feb 2026 12:58:09 +0200 Subject: [PATCH 11/63] remove dot from predict_continuous_helper for consistency --- R/posterior_predict.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 5e4e080a9..5e9e54ddf 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -314,7 +314,7 @@ posterior_predict_gaussian <- function(i, prep, ntrys = 5, output = "random", .. sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) - .predict_continuous_helper( + predict_continuous_helper( output = output, prep = prep, i = i, ntrys = ntrys, dist = "norm", mean = mu, sd = sigma, ... ) @@ -326,7 +326,7 @@ posterior_predict_student <- function(i, prep, ntrys = 5, output = "random", ... sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) - .predict_continuous_helper( + predict_continuous_helper( output = output, prep = prep, i = i, ntrys = ntrys, dist = "student_t", df = nu, mu = mu, sigma = sigma, ... ) @@ -1120,7 +1120,7 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { # @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] # @param ... additional arguments passed to the distribution functions # @return a vector of draws -.predict_continuous_helper <- function(output, prep, i, dist, ntrys, q = NULL, ...) { +predict_continuous_helper <- function(output, prep, i, dist, ntrys, q = NULL, ...) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] From f5012d811935f372906310e08a01865e9d611260 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Sat, 28 Feb 2026 13:57:49 +0200 Subject: [PATCH 12/63] support of posterior_predict for discrete distributions --- R/posterior_predict.R | 71 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 64 insertions(+), 7 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 5e9e54ddf..ccb410839 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -481,13 +481,13 @@ posterior_predict_student_fcor <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_binomial <- function(i, prep, ntrys = 5, ...) { - rdiscrete( - n = prep$ndraws, dist = "binom", - size = prep$data$trials[i], - prob = get_dpar(prep, "mu", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_binomial <- function(i, prep, ntrys = 5, output = "random", ...) { + mu = get_dpar(prep, "mu", i = i) + size = prep$data$trials[i] + + predict_discrete_helper( + output = output, i = i, prep = prep, ntrys = ntrys, + dist = "binom", prob = mu, size = size, ... ) } @@ -1058,6 +1058,32 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } +pdiscrete <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { + args <- list(...) + pdist <- paste0("p", dist) + + if (is.null(lb) && is.null(ub)) { + # non-truncated case + out <- do_call(pdist, c(list(q), args)) + } else { + # truncated case + F_q <- do_call(pdist, c(list(q), args)) + F_lb <- do_call(pdist, c(list(lb), args)) + F_ub <- do_call(pdist, c(list(ub), args)) + + scale_factor <- F_ub - F_lb + + # compute truncated CDF: (F(q) - F(lb)) / (F(ub) - F(lb)) + out <- dplyr::case_when( + q < lb ~ 0, + q > ub ~ 1, + (F_ub - F_lb) == 0 ~ 1, + TRUE ~ (F_q - F_lb) / (F_ub - F_lb) + ) + } + out +} + # sample from the IDs of the mixture components sample_mixture_ids <- function(theta) { stopifnot(is.matrix(theta)) @@ -1140,3 +1166,34 @@ predict_continuous_helper <- function(output, prep, i, dist, ntrys, q = NULL, .. } ) } + +# predict random numbers or probability values from discrete distributions +# @param output "probability" or "random" +# @param prep A named list returned by prepare_predictions containing +# all required data and posterior draws +# @param i index of the observation for which to compute pp values +# @param dist name of the distribution +# @param ntrys number of trys in rejection sampling for truncated models +# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] +# @param ... additional arguments passed to the distribution functions +# @return a vector of draws +predict_discrete_helper <- function(output, prep, i, dist, ntrys, q = NULL, ...) { + lb <- prep$data$lb[i] + ub <- prep$data$ub[i] + + switch(output, + "probability" = { + if (is.null(q)) { + q <- prep$data$Y[i] + } + pdiscrete( + q = q, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + ) + }, + "random" = { + rdiscrete( + n = prep$ndraws, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + ) + } + ) +} \ No newline at end of file From 456d4af1eeff481d7f588744bc986676405cca50 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Sat, 28 Feb 2026 13:58:13 +0200 Subject: [PATCH 13/63] add test for posterior_predict_binomial --- tests/testthat/tests.posterior_predict.R | 34 ++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 44d7236e0..5c4de164c 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -539,4 +539,38 @@ test_that("posterior_predict_student runs with various 'output' values without e qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred_trunc), ns) expect_false(all(qpred == qpred_trunc)) +}) + +test_that("posterior_predict_binomial works for different 'output' values without error", { + ns <- 25 + nobs <- 10 + trials <- sample(10:30, nobs, replace = TRUE) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + eta = matrix(rnorm(ns * nobs), ncol = nobs), + shape = rgamma(ns, 4), xi = 0, phi = rgamma(ns, 1) + ) + prep$dpars$nu <- prep$dpars$sigma <- prep$dpars$shape + 1 + i <- 3 + + prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) + + prep$data <- list( + trialsb = trials, + Y = rbinom(nobs, size = trials, prob = prep$dpars$mu) + ) + # random draws from binomial + pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random") + expect_equal(length(pred), ns) + + # compute PIT values (q = prep$data$trials[i]) + PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "probability") + expect_equal(length(PITs), ns) + expect_true(all(PITs >= 0 & PITs <= 1)) + + # compute PIT values for custom 'q' (e.g., q = 5) + qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "probability") + expect_equal(length(qpred), ns) + expect_true(all(qpred >= 0 & qpred <= 1)) + expect_false(all(PITs == qpred)) }) \ No newline at end of file From a6f2beb4c2d639416aa104a28e4999d5a0c3e07c Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Sat, 28 Feb 2026 16:27:01 +0200 Subject: [PATCH 14/63] add posterior_predict_poisson with support of diff. output values --- R/posterior_predict.R | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index ccb410839..4f23838ee 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -507,14 +507,15 @@ posterior_predict_bernoulli <- function(i, prep, ...) { rbinom(length(mu), size = 1, prob = mu) } -posterior_predict_poisson <- function(i, prep, ntrys = 5, ...) { +posterior_predict_poisson <- function(i, prep, ntrys = 5, output = "random", ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "pois", lambda = mu, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_discrete_helper( + output = output, i = i, prep = prep, ntrys = ntrys, + dist = "pois", lambda = mu, ... ) + } posterior_predict_negbinomial <- function(i, prep, ntrys = 5, ...) { @@ -1058,6 +1059,16 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } +# probability values from (possibly truncated) discrete distributions +# Note: lb and ub are treated as inclusive in order to be consistent with the +# behavior of rdiscrete. +# @param q quantile value(s) for which to compute the CDF +# @param dist name of a distribution for which the functions +# @param ... additional arguments passed to the distribution functions +# @param lb optional lower truncation bound (inclusive) +# @param ub optional upper truncation bound +# @param ntrys number of trys in rejection sampling for truncated models +# @return a vector of probability values pdiscrete <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { args <- list(...) pdist <- paste0("p", dist) @@ -1066,9 +1077,11 @@ pdiscrete <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { # non-truncated case out <- do_call(pdist, c(list(q), args)) } else { - # truncated case + # truncated case (treat lb as inclusive) F_q <- do_call(pdist, c(list(q), args)) - F_lb <- do_call(pdist, c(list(lb), args)) + # include (lb - 1) to treat lb as inclusive + # this is only relevant for discrete distributions + F_lb <- do_call(pdist, c(list(lb - 1), args)) F_ub <- do_call(pdist, c(list(ub), args)) scale_factor <- F_ub - F_lb From 41f5de0f541f92b2067fb7d6ca5f15d5e1d043e8 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Sat, 28 Feb 2026 16:27:26 +0200 Subject: [PATCH 15/63] add test for posterior_predict_poisson --- tests/testthat/tests.posterior_predict.R | 55 ++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 5c4de164c..c4b629a33 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -573,4 +573,59 @@ test_that("posterior_predict_binomial works for different 'output' values withou expect_equal(length(qpred), ns) expect_true(all(qpred >= 0 & qpred <= 1)) expect_false(all(PITs == qpred)) +}) + + +test_that("posterior_predict_poisson works for different 'output' values without error", { + set.seed(1386) + ns <- 25 + nobs <- 10 + trials <- sample(10:30, nobs, replace = TRUE) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = exp(matrix(rnorm(ns * nobs), ncol = nobs)) + ) + prep$data <- list( + Y = rpois(nobs, lambda = prep$dpars$mu) + ) + i <- 4 + + pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random") + expect_equal(length(pred), ns) + + PITs <- brms:::posterior_predict_poisson(i, prep = prep, output = "probability") + expect_equal(length(PITs), ns) + expect_true(all(PITs >= 0 & PITs <= 1)) + + # truncation interval [1, 6] + prep$data$lb <- replicate(nobs, 1) + prep$data$ub <- replicate(nobs, 6) + + rpred_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "random", ntrys = 1000) + # check whether invalid draws were returned + # in case of invalid draws, the corresponding draw is a double and not an integer + # this implementation is not ideal when posterior_predict is used by developers outside brms + # would be better to return NA for invalid draws, or to throw an error if ntrys is exceeded or so + rpred_trunc <- brms:::check_discrete_trunc_bounds(rpred_trunc, prep$data$lb[i], prep$data$ub[i]) + expect_equal(length(rpred_trunc), ns) + expect_true(all(rpred_trunc >= prep$data$lb[i] & rpred_trunc <= prep$data$ub[i])) + + PITs_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "probability") + expect_equal(length(PITs_trunc), ns) + expect_true(all(PITs_trunc >= 0 & PITs_trunc <= 1)) + + # analytical sanity check for the cdf of a zero-truncated Poisson distribution + # truncation interval [1, Inf] + .zero_trunc_pois <- function(x, lambda) { + (ppois(x, lambda = lambda) - exp(-lambda)) / (1 - exp(-lambda)) + } + prep$dpars <- list(mu = 5) + prep$data$lb <- 1. + prep$data$ub <- Inf + prep$data$Y <- rpois(1, lambda = prep$dpars$mu) + + obs_cdf <- brms:::posterior_predict_poisson(1, prep = prep, output = "probability") + expected_cdf <- .zero_trunc_pois(prep$data$Y[1], lambda = prep$dpars$mu) + + expect_equal(obs_cdf, expected_cdf) }) \ No newline at end of file From 070016a3e8858b1d22a18ff5910fdd4fe050cad2 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Fri, 13 Mar 2026 21:14:37 +0200 Subject: [PATCH 16/63] ignore agent skills --- .gitignore | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.gitignore b/.gitignore index 15d118162..27686264c 100644 --- a/.gitignore +++ b/.gitignore @@ -24,3 +24,9 @@ ignore_*/ *.tmp *.swp *~ + +# Ignore agent skills +.agent/ +.agents/ +skills/ +skills-lock.json From ee40ef6e5ed026ffbb88575505301d3627dd5a68 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Fri, 13 Mar 2026 22:41:10 +0200 Subject: [PATCH 17/63] update posterior_predict() with output argument --- DESCRIPTION | 2 + R/posterior_predict.R | 256 ++++++++++++++--------- man/posterior_predict.brmsfit.Rd | 12 +- man/predict.brmsfit.Rd | 3 +- tests/testthat/tests.posterior_predict.R | 131 +++++++++--- vignettes/brms_posterior_predict.Rmd | 230 ++++++++++++++++++++ 6 files changed, 502 insertions(+), 132 deletions(-) create mode 100644 vignettes/brms_posterior_predict.Rmd diff --git a/DESCRIPTION b/DESCRIPTION index 36cf1f84a..cf4ba8227 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -61,6 +61,8 @@ Suggests: priorsense (>= 1.0.0), shinystan (>= 2.4.0), splines2 (>= 0.5.0), + truncnorm, + dplyr, RWiener, rtdists, extraDistr, diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 4f23838ee..4402a9c0a 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -26,6 +26,12 @@ #' @param ntrys Parameter used in rejection sampling #' for truncated discrete models only #' (defaults to \code{5}). See Details for more information. +#' @param randomized Logical. Only of interest for discrete distributions. +#' Parameter used in computing the cdf of the posterior predictive +#' distribution of a discrete distribution. If \code{TRUE}, randomized PIT. +#' If \code{FALSE}, the mean between F(x) and F(x-1) is returned. +#' Defaults to \code{TRUE} for discrete distributions and is always \code{FALSE} +#' for continuous distributions. #' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, #' this argument can be set globally via the \code{mc.cores} option. #' @param ... Further arguments passed to \code{\link{prepare_predictions}} @@ -54,7 +60,8 @@ #' \dontrun{ #' ## fit a model #' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), -#' data = kidney, family = "exponential", init = "0") +#' data = kidney, family = "exponential", init = "0" +#' ) #' #' ## predicted responses #' pp <- posterior_predict(fit) @@ -83,7 +90,7 @@ posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, output = "random", - cores = NULL, ... + randomized = NULL, cores = NULL, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { @@ -92,12 +99,15 @@ posterior_predict.brmsfit <- function( contains_draws(object) object <- restructure(object) prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, + object, + newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_predict( - prep, transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE, output = output + prep, + transform = transform, sort = sort, ntrys = ntrys, + negative_rt = negative_rt, cores = cores, summary = FALSE, output = output, + randomized = randomized ) } @@ -119,9 +129,17 @@ posterior_predict.mvbrmsprep <- function(object, ...) { posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, summary = FALSE, robust = FALSE, probs = c(0.025, 0.975), - cores = NULL, ...) { + cores = NULL, output = "random", + randomized = NULL, ...) { + dots <- list(...) + dots$output <- NULL # remove output from dots to avoid passing it twice + summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) + if (!use_int(object$family) && !is.null(randomized)) { + warning2("'randomized' is ignored for continuous distributions.") + randomized <- NULL + } if (is.customfamily(object$family)) { # ensure that the method can be found during parallel execution object$family$posterior_predict <- @@ -136,7 +154,11 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, pp_fun <- paste0("posterior_predict_", object$family$fun) pp_fun <- get(pp_fun, asNamespace("brms")) N <- choose_N(object) - out <- plapply(seq_len(N), pp_fun, .cores = cores, prep = object, output = output, ...) + out <- plapply( + seq_len(N), pp_fun, + .cores = cores, prep = object, + output = output, randomized = randomized, ... + ) if (grepl("_mv$", object$family$fun)) { out <- do_call(abind, c(out, along = 3)) out <- aperm(out, perm = c(1, 3, 2)) @@ -151,15 +173,18 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, colnames(out) <- rownames(out) <- NULL if (use_int(object$family)) { out <- check_discrete_trunc_bounds( - out, lb = object$data$lb, ub = object$data$ub + out, + lb = object$data$lb, ub = object$data$ub ) } out <- reorder_obs(out, object$old_order, sort = sort) # transform predicted response draws before summarizing them if (!is.null(transform)) { # deprecated as of brms 2.12.3 - warning2("Argument 'transform' is deprecated ", - "and will be removed in the future.") + warning2( + "Argument 'transform' is deprecated ", + "and will be removed in the future." + ) out <- do_call(transform, list(out)) } attr(out, "levels") <- object$cats @@ -216,7 +241,8 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, #' \dontrun{ #' ## fit a model #' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), -#' data = kidney, family = "exponential", init = "0") +#' data = kidney, family = "exponential", init = "0" +#' ) #' #' ## predicted responses #' pp <- predict(fit) @@ -236,21 +262,26 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, #' } #' #' @export -predict.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - transform = NULL, resp = NULL, - negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, - sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, - robust = FALSE, probs = c(0.025, 0.975), ...) { +predict.brmsfit <- function( + object, newdata = NULL, re_formula = NULL, + transform = NULL, resp = NULL, + negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, + sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, + robust = FALSE, probs = c(0.025, 0.975), output = "random", + randomized = NULL, ... +) { contains_draws(object) object <- restructure(object) prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, + object, + newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_predict( - prep, transform = transform, ntrys = ntrys, negative_rt = negative_rt, + prep, + transform = transform, ntrys = ntrys, negative_rt = negative_rt, sort = sort, cores = cores, summary = summary, robust = robust, - probs = probs + probs = probs, output = output, randomized = randomized ) } @@ -309,7 +340,7 @@ validate_pp_method <- function(method) { # @param ... ignored arguments # @param A vector of length prep$ndraws containing draws # from the posterior predictive distribution -posterior_predict_gaussian <- function(i, prep, ntrys = 5, output = "random", ...) { +posterior_predict_gaussian <- function(i, prep, output, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) @@ -320,12 +351,11 @@ posterior_predict_gaussian <- function(i, prep, ntrys = 5, output = "random", .. ) } -posterior_predict_student <- function(i, prep, ntrys = 5, output = "random", ...) { +posterior_predict_student <- function(i, prep, output, ntrys = 5, ...) { nu <- get_dpar(prep, "nu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) - predict_continuous_helper( output = output, prep = prep, i = i, ntrys = ntrys, dist = "student_t", df = nu, mu = mu, sigma = sigma, ... @@ -481,13 +511,13 @@ posterior_predict_student_fcor <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_binomial <- function(i, prep, ntrys = 5, output = "random", ...) { - mu = get_dpar(prep, "mu", i = i) - size = prep$data$trials[i] - +posterior_predict_binomial <- function(i, prep, ntrys = 5, output, randomized, ...) { + mu <- get_dpar(prep, "mu", i = i) + size <- prep$data$trials[i] + predict_discrete_helper( output = output, i = i, prep = prep, ntrys = ntrys, - dist = "binom", prob = mu, size = size, ... + dist = "binom", randomized = randomized, prob = mu, size = size, ... ) } @@ -507,15 +537,15 @@ posterior_predict_bernoulli <- function(i, prep, ...) { rbinom(length(mu), size = 1, prob = mu) } -posterior_predict_poisson <- function(i, prep, ntrys = 5, output = "random", ...) { +# TODO: Do we want to set "randomized = TRUE" by default? +posterior_predict_poisson <- function(i, prep, ntrys = 5, output, randomized, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) predict_discrete_helper( output = output, i = i, prep = prep, ntrys = ntrys, - dist = "pois", lambda = mu, ... + dist = "pois", randomized = randomized, lambda = mu, ... ) - } posterior_predict_negbinomial <- function(i, prep, ntrys = 5, ...) { @@ -733,8 +763,10 @@ posterior_predict_zero_inflated_asym_laplace <- function(i, prep, ntrys = 5, } posterior_predict_cox <- function(i, prep, ...) { - stop2("Cannot sample from the posterior predictive ", - "distribution for family 'cox'.") + stop2( + "Cannot sample from the posterior predictive ", + "distribution for family 'cox'." + ) } posterior_predict_hurdle_poisson <- function(i, prep, ...) { @@ -746,7 +778,7 @@ posterior_predict_hurdle_poisson <- function(i, prep, ...) { tmp <- runif(ndraws, 0, 1) # sample from a truncated poisson distribution # by adjusting lambda and adding 1 - t = -log(1 - runif(ndraws) * (1 - exp(-lambda))) + t <- -log(1 - runif(ndraws) * (1 - exp(-lambda))) ifelse(tmp < hu, 0, rpois(ndraws, lambda = lambda - t) + 1) } @@ -757,7 +789,7 @@ posterior_predict_hurdle_negbinomial <- function(i, prep, ...) { tmp <- runif(ndraws, 0, 1) # sample from an approximate(!) truncated negbinomial distribution # by adjusting mu and adding 1 - t = -log(1 - runif(ndraws) * (1 - exp(-mu))) + t <- -log(1 - runif(ndraws) * (1 - exp(-mu))) shape <- get_dpar(prep, "shape", i = i) ifelse(tmp < hu, 0, rnbinom(ndraws, mu = mu - t, size = shape) + 1) } @@ -909,8 +941,10 @@ posterior_predict_logistic_normal <- function(i, prep, ...) { mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i, cor_name = "lncor") .predict <- function(s) { - rlogistic_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ], - refcat = prep$refcat) + rlogistic_normal(1, + mu = mu[s, ], Sigma = Sigma[s, , ], + refcat = prep$refcat + ) } rblapply(seq_len(prep$ndraws), .predict) } @@ -975,10 +1009,11 @@ posterior_predict_mixture <- function(i, prep, ...) { # @param ntrys number of trys in rejection sampling for truncated models # @return vector of random values prep from the distribution rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- list(...) + args <- validate_args(dist, ...) + if (is.null(lb) && is.null(ub)) { - # sample as usual rdist <- paste0("r", dist) + # sample as usual out <- do_call(rdist, c(list(n), args)) } else { # sample from truncated distribution @@ -1001,30 +1036,14 @@ rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } -pcontinuous <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- list(...) +pcontinuous <- function(q, dist, randomized, ..., lb, ub) { + args <- validate_args(dist, ...) pdist <- paste0("p", dist) - if (is.null(lb) && is.null(ub)) { - # non-truncated case - out <- do_call(pdist, c(list(q), args)) - } else { - # truncated case - F_q <- do_call(pdist, c(list(q), args)) - F_lb <- do_call(pdist, c(list(lb), args)) - F_ub <- do_call(pdist, c(list(ub), args)) - - scale_factor <- F_ub - F_lb - - # compute truncated CDF: (F(q) - F(lb)) / (F(ub) - F(lb)) - out <- dplyr::case_when( - q < lb ~ 0, - q > ub ~ 1, - (F_ub - F_lb) == 0 ~ 1, - TRUE ~ (F_q - F_lb) / (F_ub - F_lb) - ) - } - out + compute_cdf( + q = q, pdist = pdist, args = args, lb = lb, ub = ub, + randomized + ) } # random numbers from (possibly truncated) discrete distributions @@ -1038,8 +1057,9 @@ pcontinuous <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { # @param ntrys number of trys in rejection sampling for truncated models # @return a vector of random values draws from the distribution rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- list(...) + args <- validate_args(dist, ...) rdist <- paste0("r", dist) + if (is.null(lb) && is.null(ub)) { # sample as usual out <- do_call(rdist, c(list(n), args)) @@ -1060,7 +1080,7 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { } # probability values from (possibly truncated) discrete distributions -# Note: lb and ub are treated as inclusive in order to be consistent with the +# Note: lb and ub are treated as inclusive in order to be consistent with the # behavior of rdiscrete. # @param q quantile value(s) for which to compute the CDF # @param dist name of a distribution for which the functions @@ -1069,41 +1089,23 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { # @param ub optional upper truncation bound # @param ntrys number of trys in rejection sampling for truncated models # @return a vector of probability values -pdiscrete <- function(q, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- list(...) +pdiscrete <- function(q, dist, randomized, ..., lb, ub) { + args <- validate_args(dist, ...) pdist <- paste0("p", dist) - - if (is.null(lb) && is.null(ub)) { - # non-truncated case - out <- do_call(pdist, c(list(q), args)) - } else { - # truncated case (treat lb as inclusive) - F_q <- do_call(pdist, c(list(q), args)) - # include (lb - 1) to treat lb as inclusive - # this is only relevant for discrete distributions - F_lb <- do_call(pdist, c(list(lb - 1), args)) - F_ub <- do_call(pdist, c(list(ub), args)) - - scale_factor <- F_ub - F_lb - - # compute truncated CDF: (F(q) - F(lb)) / (F(ub) - F(lb)) - out <- dplyr::case_when( - q < lb ~ 0, - q > ub ~ 1, - (F_ub - F_lb) == 0 ~ 1, - TRUE ~ (F_q - F_lb) / (F_ub - F_lb) - ) - } - out + + compute_cdf( + q = q, pdist = pdist, args = args, lb = lb, ub = ub, + randomized = randomized + ) } # sample from the IDs of the mixture components sample_mixture_ids <- function(theta) { stopifnot(is.matrix(theta)) mix_comp <- seq_cols(theta) - ulapply(seq_rows(theta), function(s) + ulapply(seq_rows(theta), function(s) { sample(mix_comp, 1, prob = theta[s, ]) - ) + }) } # extract the first valid predicted value per Stan sample per observation @@ -1156,20 +1158,24 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { # @param i index of the observation for which to compute pp values # @param dist name of the distribution # @param ntrys number of trys in rejection sampling for truncated models -# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] +# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] +# @param randomized NULL or logical indicating whether to use the randomized PIT +# NULL for continuous distributions. # @param ... additional arguments passed to the distribution functions # @return a vector of draws -predict_continuous_helper <- function(output, prep, i, dist, ntrys, q = NULL, ...) { +predict_continuous_helper <- function( + output, prep, i, dist, ntrys, q = NULL, randomized, ... +) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] - + switch(output, "probability" = { if (is.null(q)) { q <- prep$data$Y[i] } pcontinuous( - q = q, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + q = q, dist = dist, lb = lb, ub = ub, randomized = randomized, ... ) }, "random" = { @@ -1187,20 +1193,24 @@ predict_continuous_helper <- function(output, prep, i, dist, ntrys, q = NULL, .. # @param i index of the observation for which to compute pp values # @param dist name of the distribution # @param ntrys number of trys in rejection sampling for truncated models -# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] +# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] # @param ... additional arguments passed to the distribution functions # @return a vector of draws -predict_discrete_helper <- function(output, prep, i, dist, ntrys, q = NULL, ...) { +predict_discrete_helper <- function( + output, prep, i, dist, ntrys, q = NULL, randomized, ... +) { + randomized <- randomized %||% TRUE + lb <- prep$data$lb[i] ub <- prep$data$ub[i] - + switch(output, "probability" = { if (is.null(q)) { q <- prep$data$Y[i] } pdiscrete( - q = q, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + q = q, dist = dist, randomized = randomized, lb = lb, ub = ub, ... ) }, "random" = { @@ -1209,4 +1219,54 @@ predict_discrete_helper <- function(output, prep, i, dist, ntrys, q = NULL, ...) ) } ) -} \ No newline at end of file +} + +# compute cdf dependent on whether the distribution is truncated or not +# and whether to use the randomized PIT +# @param q quantile value(s) for which to compute the CDF +# @param pdist name of the distribution function +# @param args additional arguments passed to the distribution functions +# @param lb optional lower truncation bound +# @param ub optional upper truncation bound +# @param randomized NULL or logical indicating whether to use the randomized PIT +# NULL for continuous distributions. +# @return a vector of probability values +# @noRd +compute_cdf <- function(q, pdist, args, lb, ub, randomized) { + # prepare computation of (non-)truncated cdf + F_internal <- function(q) { + if (is.null(lb) && is.null(ub)) { + do_call(pdist, c(list(q), args)) + } else { + denom <- do_call(pdist, c(list(ub), args)) - do_call(pdist, c(list(lb), args)) + if (any(denom == 0)) stop("Division by zero") + (do_call(pdist, c(list(q), args)) - do_call(pdist, c(list(lb), args))) / denom + } + } + # randomized PIT specifically for discrete data (see, e.g., + # Czado, C., Gneiting, T., Held, L.: Predictive model + # assessment for count data. Biometrics 65(4), 1254–1261 (2009).) + # F(y-1) + V * [F(y) - F(y-1)] with V ~ Unif(0,1) + if (isTRUE(randomized)) { + v <- runif(length(q)) + F_internal(q - 1) + v * (F_internal(q) - F_internal(q - 1)) + } else if (isFALSE(randomized)) { + 0.5 * (F_internal(q) + F_internal(q - 1)) # TODO: Is this okay as non-randomized solution + } else if (is.null(randomized)) { + F_internal(q) + } +} + +# ensure that only arguments that are accepted by the RNG are passed +validate_args <- function(dist, ...) { + args <- list(...) + rdist <- paste0("p", dist) + rdist_fun <- match.fun(rdist) + rdist_formals <- names(formals(rdist_fun)) + + if (!is.null(rdist_formals) && !("..." %in% rdist_formals)) { + args <- args[names(args) %in% rdist_formals] + } + + args + } \ No newline at end of file diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index 3e3f89740..2d6d75154 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -17,6 +17,8 @@ draw_ids = NULL, sort = FALSE, ntrys = 5, + output = "random", + randomized = NULL, cores = NULL, ... ) @@ -66,6 +68,13 @@ time series (\code{TRUE}).} for truncated discrete models only (defaults to \code{5}). See Details for more information.} +\item{randomized}{Logical. Only of interest for discrete distributions. +Parameter used in computing the cdf of the posterior predictive +distribution of a discrete distribution. If \code{TRUE}, randomized PIT. +If \code{FALSE}, the mean between F(x) and F(x-1) is returned. +Defaults to \code{TRUE} for discrete distributions and is always \code{FALSE} +for continuous distributions.} + \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} @@ -117,7 +126,8 @@ For truncated discrete models only: In the absence of any general \dontrun{ ## fit a model fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), - data = kidney, family = "exponential", init = "0") + data = kidney, family = "exponential", init = "0" +) ## predicted responses pp <- posterior_predict(fit) diff --git a/man/predict.brmsfit.Rd b/man/predict.brmsfit.Rd index a197c395f..26f8cf4cc 100644 --- a/man/predict.brmsfit.Rd +++ b/man/predict.brmsfit.Rd @@ -108,7 +108,8 @@ with additional arguments for obtaining summaries of the computed draws. \dontrun{ ## fit a model fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), - data = kidney, family = "exponential", init = "0") + data = kidney, family = "exponential", init = "0" +) ## predicted responses pp <- predict(fit) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index c4b629a33..53f9bf6fe 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -10,10 +10,10 @@ test_that("posterior_predict for location shift models runs without errors", { ) i <- sample(nobs, 1) - pred <- brms:::posterior_predict_gaussian(i, prep = prep) + pred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") expect_equal(length(pred), ns) - pred <- brms:::posterior_predict_student(i, prep = prep) + pred <- brms:::posterior_predict_student(i, prep = prep, output = "random") expect_equal(length(pred), ns) }) @@ -149,7 +149,8 @@ test_that("posterior_predict for count and survival models runs without errors", i <- sample(nobs, 1) prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) - pred <- brms:::posterior_predict_binomial(i, prep = prep) + pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random", + randomized = NULL) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_beta_binomial(i, prep = prep) @@ -159,7 +160,7 @@ test_that("posterior_predict for count and survival models runs without errors", expect_equal(length(pred), ns) prep$dpars$mu <- exp(prep$dpars$eta) - pred <- brms:::posterior_predict_poisson(i, prep = prep) + pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random", randomized = NULL) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_negbinomial(i, prep = prep) @@ -392,16 +393,18 @@ test_that("truncated posterior_predict run without errors", { prep$refcat <- 1 prep$data <- list(lb = sample(-(4:7), nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_gaussian, prep = prep) + pred <- sapply(1:nobs, brms:::posterior_predict_gaussian, prep = prep, output = "random") expect_equal(dim(pred), c(ns, nobs)) prep$dpars$mu <- exp(prep$dpars$mu) prep$data <- list(ub = sample(70:80, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random", + randomized = NULL) expect_equal(dim(pred), c(ns, nobs)) prep$data <- list(lb = rep(0, nobs), ub = sample(70:75, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random", + randomized = NULL) expect_equal(dim(pred), c(ns, nobs)) }) @@ -452,12 +455,14 @@ test_that("posterior_predict_gaussian runs with various 'output' values without expect_equal(length(rpred), S) # compute PIT values (q = prep$data$Y[i]) - PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") + PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability", + randomized = NULL) expect_equal(length(PITs), S) expect_true(all(PITs >= 0 & PITs <= 1)) # compute cdf based on custom 'q' - qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability") + qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability", + randomized = NULL) expect_equal(length(qpred), S) expect_false(all(PITs == qpred)) expect_true(all(qpred >= 0 & qpred <= 1)) @@ -513,12 +518,14 @@ test_that("posterior_predict_student runs with various 'output' values without e expect_equal(length(rpred), ns) # compute PIT values (q = prep$data$Y[i]) - PITs <- brms:::posterior_predict_student(i, prep = prep, output = "probability") + PITs <- brms:::posterior_predict_student(i, prep = prep, output = "probability", + randomized = NULL) expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) # compute cdf based on custom 'q' - qpred <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") + qpred <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability", + randomized = NULL) expect_equal(length(qpred), ns) expect_false(all(PITs == qpred)) expect_true(all(qpred >= 0 & qpred <= 1)) @@ -531,12 +538,14 @@ test_that("posterior_predict_student runs with various 'output' values without e expect_true(all(rpred >= prep$data$lb[i] & rpred <= prep$data$ub[i])) # compute PIT values for truncated t (q = prep$data$Y[i]) - PITs_trunc <- brms:::posterior_predict_student(i, prep = prep, output = "probability") + PITs_trunc <- brms:::posterior_predict_student(i, prep = prep, output = "probability", + randomized = NULL) expect_equal(length(PITs_trunc), ns) expect_false(all(PITs == PITs_trunc)) # compute cdf for truncated t based on custom 'q' - qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") + qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability", + randomized = NULL) expect_equal(length(qpred_trunc), ns) expect_false(all(qpred == qpred_trunc)) }) @@ -560,16 +569,16 @@ test_that("posterior_predict_binomial works for different 'output' values withou Y = rbinom(nobs, size = trials, prob = prep$dpars$mu) ) # random draws from binomial - pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random") + pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random", randomized = NULL) expect_equal(length(pred), ns) # compute PIT values (q = prep$data$trials[i]) - PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "probability") + PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "probability", randomized = TRUE) expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) # compute PIT values for custom 'q' (e.g., q = 5) - qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "probability") + qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "probability", randomized = TRUE) expect_equal(length(qpred), ns) expect_true(all(qpred >= 0 & qpred <= 1)) expect_false(all(PITs == qpred)) @@ -590,10 +599,13 @@ test_that("posterior_predict_poisson works for different 'output' values without ) i <- 4 - pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random") + pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random", + randomized = NULL) expect_equal(length(pred), ns) - PITs <- brms:::posterior_predict_poisson(i, prep = prep, output = "probability") + PITs <- posterior_predict_poisson( + i, prep = prep, output = "probability", randomized = TRUE + ) expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) @@ -601,7 +613,8 @@ test_that("posterior_predict_poisson works for different 'output' values without prep$data$lb <- replicate(nobs, 1) prep$data$ub <- replicate(nobs, 6) - rpred_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "random", ntrys = 1000) + rpred_trunc <- posterior_predict_poisson(i, prep = prep, output = "random", ntrys = 1000, + randomized = NULL) # check whether invalid draws were returned # in case of invalid draws, the corresponding draw is a double and not an integer # this implementation is not ideal when posterior_predict is used by developers outside brms @@ -610,22 +623,76 @@ test_that("posterior_predict_poisson works for different 'output' values without expect_equal(length(rpred_trunc), ns) expect_true(all(rpred_trunc >= prep$data$lb[i] & rpred_trunc <= prep$data$ub[i])) - PITs_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "probability") + PITs_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "probability", randomized = TRUE) expect_equal(length(PITs_trunc), ns) expect_true(all(PITs_trunc >= 0 & PITs_trunc <= 1)) +}) - # analytical sanity check for the cdf of a zero-truncated Poisson distribution - # truncation interval [1, Inf] - .zero_trunc_pois <- function(x, lambda) { - (ppois(x, lambda = lambda) - exp(-lambda)) / (1 - exp(-lambda)) - } - prep$dpars <- list(mu = 5) - prep$data$lb <- 1. - prep$data$ub <- Inf - prep$data$Y <- rpois(1, lambda = prep$dpars$mu) +test_that("compute_cdf returns correct CDF for non-truncated distributions", { + # Non-truncated, non-randomized: raw CDF F(q) + q <- 3 + args <- list(lambda = 5) + out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = NULL, ub = NULL, + randomized = NULL) + expect_equal(out, ppois(q, lambda = 5)) + + q <- 2 + args <- list(size = 10, prob = 0.5) + out <- brms:::compute_cdf(q = q, pdist = "pbinom", args = args, lb = NULL, ub = NULL, + randomized = NULL) + expect_equal(out, pbinom(q, size = 10, prob = 0.5)) +}) - obs_cdf <- brms:::posterior_predict_poisson(1, prep = prep, output = "probability") - expected_cdf <- .zero_trunc_pois(prep$data$Y[1], lambda = prep$dpars$mu) +test_that("compute_cdf with randomized = FALSE returns value in [0, 1]", { + q <- 5 + args <- list(lambda = 3) + out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = NULL, ub = NULL, randomized = FALSE) + expect_true(out >= 0 && out <= 1) +}) + +test_that("compute_cdf with randomized = TRUE returns value in [F(q-1), F(q)]", { + # Randomized PIT: F(y-1) + V * [F(y) - F(y-1)] with V ~ Unif(0,1) + set.seed(42) + q <- 5 + args <- list(lambda = 3) + Fq <- ppois(q, lambda = 3) + Fqm1 <- ppois(q - 1, lambda = 3) + + out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = NULL, ub = NULL, randomized = TRUE) + expect_true(out >= Fqm1) + expect_true(out <= Fq) +}) - expect_equal(obs_cdf, expected_cdf) +test_that("compute_cdf with randomized = TRUE and truncation returns value in valid range", { + set.seed(123) + q <- 4 + args <- list(lambda = 5) + lb <- 2 + ub <- 7 + denom <- ppois(ub, lambda = 5) - ppois(lb, lambda = 5) + Fq <- (ppois(q, lambda = 5) - ppois(lb, lambda = 5)) / denom + Fqm1 <- (ppois(q - 1, lambda = 5) - ppois(lb, lambda = 5)) / denom + + out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = lb, ub = ub, randomized = TRUE) + expect_true(out >= Fqm1) + expect_true(out <= Fq) + expect_true(out >= 0 && out <= 1) +}) + +test_that("compute_cdf handles zero denominator (lb == ub) without unexpected behaviour", { + q <- 3 + args <- list(lambda = 2) + lb <- 1 + ub <- 1 + + out <- tryCatch( + brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = lb, ub = ub, randomized = FALSE), + error = function(e) structure(list(error = TRUE, message = e$message)) + ) + + if (is.list(out) && isTRUE(out$error)) { + expect_true(grepl("zero|denom|divide|trunc", out$message, ignore.case = TRUE)) + } else { + expect_true(is.nan(out) || is.na(out)) + } }) \ No newline at end of file diff --git a/vignettes/brms_posterior_predict.Rmd b/vignettes/brms_posterior_predict.Rmd new file mode 100644 index 000000000..2a1a8ed77 --- /dev/null +++ b/vignettes/brms_posterior_predict.Rmd @@ -0,0 +1,230 @@ +--- +title: "Using `posterior_predict` with varying output values" +author: "TODO" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Using `posterior_predict` with varying output values} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +knit_hooks$set(pngquant = knitr::hook_pngquant) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "ragg_png", + dpi = 72, + fig.retina = 1.5, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center", + pngquant = "--speed=1 --quality=50" +) +library(ggplot2) +devtools::load_all() +library(extraDistr) +library(dplyr) +theme_set(theme_default()) + +n <- 200 +``` + +## Binomial model +### Calibrated + +```{r binom1-fit, include = FALSE} +set.seed(42) +beta0 <- -1 +beta1 <- 0.8 + +dat_binom <- dplyr::tibble( + x = rnorm(n), + size = sample(10:30, n, replace = TRUE), + y = rbinom(n, size = size, prob = plogis(beta0 + beta1 * x)) + ) + +fit_binom_calibrated <- brms::brm( + formula = "y | trials(size) ~ x", + data = dat_binom, + family = binomial(link = "logit"), + chains = 2, + seed = 42 +) +``` + +```{r binom1-dens} +bayesplot::ppc_bars( + y = dat_binom$y, + yrep = posterior_predict(fit_binom_calibrated) + ) +``` + +```{r binom1-ecdf-random} +PITs = posterior_predict( + fit_binom_calibrated, output = "probability" + ) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Binomial model with randomized PIT") +``` + +```{r binom1-ecdf} +PITs = posterior_predict( + fit_binom_calibrated, output = "probability", randomized = FALSE + ) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Binomial model with non-randomized PIT") +``` + +### Miscalibrated +```{r binom2-fit, include=FALSE} +phi <- 2 +alpha <- phi * 0.3 +beta <- phi * (1 - 0.3) + +dat_overdisp <- dplyr::tibble( + x = rnorm(n), + size = sample(10:30, n, replace = TRUE), + y = rbbinom(n, size = size, alpha = alpha, beta = beta) +) + +fit_binom_miscalibrated <- brms::brm( + formula = "y | trials(size) ~ x", + data = dat_overdisp, + family = binomial(link = "logit"), + chains = 2, + seed = 42 +) +``` + +```{r binom2-dens} +bayesplot::ppc_bars( + y = dat_overdisp$y, + yrep = posterior_predict(fit_binom_miscalibrated) + ) +``` + +```{r binom2-ecdf-random} +PITs = posterior_predict( + fit_binom_miscalibrated, output = "probability" + ) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Binomial model with randomized PIT \n(miscalibrated)") +``` + +```{r binom2-ecdf} +PITs = posterior_predict( + fit_binom_miscalibrated, output = "probability", randomized = FALSE + ) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Binomial model with non-randomized PIT \n(miscalibrated)") +``` + +## Poisson + +```{r pois-fit, include = FALSE} +beta0 <- 0.5 +beta1 <- 0.8 + +dat_pois <- dplyr::tibble( + x = rnorm(n), + y = rpois(n, lambda = exp(beta0 + beta1 * x)) + ) + +fit_pois <- brm( + formula = "y ~ x", + data = dat_pois, + family = poisson(link = "log"), + chains = 2, + seed = 42 +) +``` + +```{r pois-dens} +bayesplot::ppc_bars( + y = dat_pois$y, + yrep = posterior_predict(fit_pois) + ) +``` + +```{r pois-ecdf-random} +PITs = posterior_predict( + fit_pois, output = "probability" + ) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Poisson model with randomized PIT") +``` + +```{r pois-ecdf} +PITs = posterior_predict( + fit_pois, output = "probability", randomized = FALSE + ) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Poisson model with non-randomized PIT") +``` + +## Normal + +```{r norm-fit, include = FALSE} +dat_normal <- dplyr::tibble( + y = rnorm(n, mean = 1.0, sd = 0.8) + ) + +fit_norm <- brm( + formula = "y ~ 1", + data = dat_normal, + family = gaussian(), + chains = 2, + seed = 42 +) +``` + +```{r norm-dens} +bayesplot::ppc_dens_overlay( + y = dat_normal$y, + yrep = posterior_predict(fit_norm) + ) +``` + +```{r norm-ecdf} +PITs = posterior_predict(fit_norm, output = "probability") +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) +``` + +## Student-t + +```{r t-fit, include = FALSE} +dat_student <- dplyr::tibble( + y = rt(n, df = 5) + ) + +fit_student <- brm( + formula = "y ~ 1", + data = dat_student, + family = student(), + chains = 2, + seed = 42 +) +``` + +```{r t-dens} +bayesplot::ppc_dens_overlay( + y = dat_student$y, + yrep = posterior_predict(fit_student) + ) +``` + +```{r t-ecdf} +PITs = posterior_predict(fit_student, output = "probability") +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) +``` \ No newline at end of file From 6a0a2ce66756afbcb8f8f732f305c1e3fa807372 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 16 Mar 2026 12:43:06 +0200 Subject: [PATCH 18/63] update posterior_predict with outcome values probability, random, pit --- R/posterior_predict.R | 135 +++++++++++++---------- man/posterior_predict.brmsfit.Rd | 11 +- man/predict.brmsfit.Rd | 6 + tests/testthat/tests.posterior_predict.R | 51 ++++----- vignettes/brms_posterior_predict.Rmd | 53 ++++----- 5 files changed, 134 insertions(+), 122 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 4402a9c0a..7d2bca594 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -26,12 +26,10 @@ #' @param ntrys Parameter used in rejection sampling #' for truncated discrete models only #' (defaults to \code{5}). See Details for more information. -#' @param randomized Logical. Only of interest for discrete distributions. -#' Parameter used in computing the cdf of the posterior predictive -#' distribution of a discrete distribution. If \code{TRUE}, randomized PIT. -#' If \code{FALSE}, the mean between F(x) and F(x-1) is returned. -#' Defaults to \code{TRUE} for discrete distributions and is always \code{FALSE} -#' for continuous distributions. +#' @param output The type of output to return. Can be \code{"random"}, +#' \code{"probability"}, or \code{"pit"}. Defaults to \code{"random"}. +#' In case of continuous distributions, \code{"probability"} is equivalent +#' to \code{"pit"}. #' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, #' this argument can be set globally via the \code{mc.cores} option. #' @param ... Further arguments passed to \code{\link{prepare_predictions}} @@ -89,8 +87,8 @@ posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, - ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, output = "random", - randomized = NULL, cores = NULL, ... + ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, + output = "random", cores = NULL, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { @@ -106,8 +104,8 @@ posterior_predict.brmsfit <- function( posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE, output = output, - randomized = randomized + negative_rt = negative_rt, cores = cores, summary = FALSE, + output = output ) } @@ -129,17 +127,19 @@ posterior_predict.mvbrmsprep <- function(object, ...) { posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, summary = FALSE, robust = FALSE, probs = c(0.025, 0.975), - cores = NULL, output = "random", - randomized = NULL, ...) { + cores = NULL, output = "random", ...) { dots <- list(...) dots$output <- NULL # remove output from dots to avoid passing it twice + output <- as_one_character(output) + if (!output %in% c("random", "probability", "pit")) { + stop2("Argument 'output' must be one of ", + "'random', 'probability', or 'pit'.") + } + summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) - if (!use_int(object$family) && !is.null(randomized)) { - warning2("'randomized' is ignored for continuous distributions.") - randomized <- NULL - } + if (is.customfamily(object$family)) { # ensure that the method can be found during parallel execution object$family$posterior_predict <- @@ -157,7 +157,7 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, out <- plapply( seq_len(N), pp_fun, .cores = cores, prep = object, - output = output, randomized = randomized, ... + output = output, ... ) if (grepl("_mv$", object$family$fun)) { out <- do_call(abind, c(out, along = 3)) @@ -267,8 +267,8 @@ predict.brmsfit <- function( transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, - robust = FALSE, probs = c(0.025, 0.975), output = "random", - randomized = NULL, ... + robust = FALSE, probs = c(0.025, 0.975), + output = "random", ... ) { contains_draws(object) object <- restructure(object) @@ -281,7 +281,7 @@ predict.brmsfit <- function( prep, transform = transform, ntrys = ntrys, negative_rt = negative_rt, sort = sort, cores = cores, summary = summary, robust = robust, - probs = probs, output = output, randomized = randomized + probs = probs, output = output ) } @@ -511,13 +511,13 @@ posterior_predict_student_fcor <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_binomial <- function(i, prep, ntrys = 5, output, randomized, ...) { +posterior_predict_binomial <- function(i, prep, ntrys = 5, output, ...) { mu <- get_dpar(prep, "mu", i = i) size <- prep$data$trials[i] predict_discrete_helper( output = output, i = i, prep = prep, ntrys = ntrys, - dist = "binom", randomized = randomized, prob = mu, size = size, ... + dist = "binom", prob = mu, size = size, ... ) } @@ -537,14 +537,13 @@ posterior_predict_bernoulli <- function(i, prep, ...) { rbinom(length(mu), size = 1, prob = mu) } -# TODO: Do we want to set "randomized = TRUE" by default? -posterior_predict_poisson <- function(i, prep, ntrys = 5, output, randomized, ...) { +posterior_predict_poisson <- function(i, prep, ntrys = 5, output, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) predict_discrete_helper( output = output, i = i, prep = prep, ntrys = ntrys, - dist = "pois", randomized = randomized, lambda = mu, ... + dist = "pois", lambda = mu, ... ) } @@ -1001,7 +1000,7 @@ posterior_predict_mixture <- function(i, prep, ...) { } # ------------ predict helper-functions ---------------------- -# random numbers from (possibly truncated) continuous distributions +# random numbers from (possibly truncated) continuous distributions # @param n number of random values to generate # @param dist name of a distribution for which the functions # p, q, and r are available @@ -1036,13 +1035,24 @@ rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } -pcontinuous <- function(q, dist, randomized, ..., lb, ub) { +# probability values from (possibly truncated) continuous distributions +# @param q quantile value(s) for which to compute the CDF +# @param dist name of a distribution for which the functions +# @param ... additional arguments passed to the distribution functions +# @param randomized logical indicating whether to use the randomized PIT. +# For continuous distributions, this is always FALSE; thus computes +# standard cdf value. +# @param lb optional lower truncation bound +# @param ub optional upper truncation bound +# @return a vector of probability values +# @noRd +pcontinuous <- function(q, dist, ..., randomized = FALSE, lb, ub) { args <- validate_args(dist, ...) pdist <- paste0("p", dist) compute_cdf( q = q, pdist = pdist, args = args, lb = lb, ub = ub, - randomized + randomized = randomized ) } @@ -1085,14 +1095,14 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { # @param q quantile value(s) for which to compute the CDF # @param dist name of a distribution for which the functions # @param ... additional arguments passed to the distribution functions +# @param randomized logical indicating whether to use the randomized PIT. # @param lb optional lower truncation bound (inclusive) # @param ub optional upper truncation bound -# @param ntrys number of trys in rejection sampling for truncated models # @return a vector of probability values -pdiscrete <- function(q, dist, randomized, ..., lb, ub) { +pdiscrete <- function(q, dist, ..., randomized, lb, ub) { args <- validate_args(dist, ...) pdist <- paste0("p", dist) - + compute_cdf( q = q, pdist = pdist, args = args, lb = lb, ub = ub, randomized = randomized @@ -1151,20 +1161,18 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { round(x) } -# predict random numbers or probability values from continuous distributions -# @param output "probability" or "random" +# predict random numbers or probability / PIT values from continuous distributions +# @param output "random", "probability", or "pit" (treated as "probability") # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws # @param i index of the observation for which to compute pp values # @param dist name of the distribution # @param ntrys number of trys in rejection sampling for truncated models # @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] -# @param randomized NULL or logical indicating whether to use the randomized PIT -# NULL for continuous distributions. # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_continuous_helper <- function( - output, prep, i, dist, ntrys, q = NULL, randomized, ... + output, prep, i, dist, ntrys, q = NULL, ... ) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] @@ -1175,19 +1183,28 @@ predict_continuous_helper <- function( q <- prep$data$Y[i] } pcontinuous( - q = q, dist = dist, lb = lb, ub = ub, randomized = randomized, ... + q = q, dist = dist, lb = lb, ub = ub, ... + ) + }, + "pit" = { + if (is.null(q)) { + q <- prep$data$Y[i] + } + pcontinuous( + q = q, dist = dist, lb = lb, ub = ub, ... ) }, "random" = { rcontinuous( - n = prep$ndraws, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... + n = prep$ndraws, dist = dist, lb = lb, ub = ub, + ntrys = ntrys, ... ) } ) } -# predict random numbers or probability values from discrete distributions -# @param output "probability" or "random" +# predict random numbers or probability / PIT values from discrete distributions +# @param output "random", "probability", or "pit" (treated as "probability") # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws # @param i index of the observation for which to compute pp values @@ -1197,10 +1214,8 @@ predict_continuous_helper <- function( # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_discrete_helper <- function( - output, prep, i, dist, ntrys, q = NULL, randomized, ... + output, prep, i, dist, ntrys, q = NULL, ... ) { - randomized <- randomized %||% TRUE - lb <- prep$data$lb[i] ub <- prep$data$ub[i] @@ -1210,7 +1225,15 @@ predict_discrete_helper <- function( q <- prep$data$Y[i] } pdiscrete( - q = q, dist = dist, randomized = randomized, lb = lb, ub = ub, ... + q = q, dist = dist, randomized = FALSE, lb = lb, ub = ub, ... + ) + }, + "pit" = { + if (is.null(q)) { + q <- prep$data$Y[i] + } + pdiscrete( + q = q, dist = dist, randomized = TRUE, lb = lb, ub = ub, ... ) }, "random" = { @@ -1228,8 +1251,7 @@ predict_discrete_helper <- function( # @param args additional arguments passed to the distribution functions # @param lb optional lower truncation bound # @param ub optional upper truncation bound -# @param randomized NULL or logical indicating whether to use the randomized PIT -# NULL for continuous distributions. +# @param randomized logical indicating whether to use the randomized PIT # @return a vector of probability values # @noRd compute_cdf <- function(q, pdist, args, lb, ub, randomized) { @@ -1251,22 +1273,19 @@ compute_cdf <- function(q, pdist, args, lb, ub, randomized) { v <- runif(length(q)) F_internal(q - 1) + v * (F_internal(q) - F_internal(q - 1)) } else if (isFALSE(randomized)) { - 0.5 * (F_internal(q) + F_internal(q - 1)) # TODO: Is this okay as non-randomized solution - } else if (is.null(randomized)) { F_internal(q) } } - # ensure that only arguments that are accepted by the RNG are passed validate_args <- function(dist, ...) { - args <- list(...) - rdist <- paste0("p", dist) - rdist_fun <- match.fun(rdist) - rdist_formals <- names(formals(rdist_fun)) + args <- list(...) + rdist <- paste0("p", dist) + rdist_fun <- match.fun(rdist) + rdist_formals <- names(formals(rdist_fun)) - if (!is.null(rdist_formals) && !("..." %in% rdist_formals)) { - args <- args[names(args) %in% rdist_formals] - } + if (!is.null(rdist_formals) && !("..." %in% rdist_formals)) { + args <- args[names(args) %in% rdist_formals] + } - args - } \ No newline at end of file + args +} \ No newline at end of file diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index 2d6d75154..289e4dcd4 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -18,7 +18,6 @@ sort = FALSE, ntrys = 5, output = "random", - randomized = NULL, cores = NULL, ... ) @@ -68,12 +67,10 @@ time series (\code{TRUE}).} for truncated discrete models only (defaults to \code{5}). See Details for more information.} -\item{randomized}{Logical. Only of interest for discrete distributions. -Parameter used in computing the cdf of the posterior predictive -distribution of a discrete distribution. If \code{TRUE}, randomized PIT. -If \code{FALSE}, the mean between F(x) and F(x-1) is returned. -Defaults to \code{TRUE} for discrete distributions and is always \code{FALSE} -for continuous distributions.} +\item{output}{The type of output to return. Can be \code{"random"}, +\code{"probability"}, or \code{"pit"}. Defaults to \code{"random"}. +In case of continuous distributions, \code{"probability"} is equivalent +to \code{"pit"}.} \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} diff --git a/man/predict.brmsfit.Rd b/man/predict.brmsfit.Rd index 26f8cf4cc..8e51b8f63 100644 --- a/man/predict.brmsfit.Rd +++ b/man/predict.brmsfit.Rd @@ -19,6 +19,7 @@ summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), + output = "random", ... ) } @@ -80,6 +81,11 @@ Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} +\item{output}{The type of output to return. Can be \code{"random"}, +\code{"probability"}, or \code{"pit"}. Defaults to \code{"random"}. +In case of continuous distributions, \code{"probability"} is equivalent +to \code{"pit"}.} + \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 53f9bf6fe..36dae091e 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -149,8 +149,7 @@ test_that("posterior_predict for count and survival models runs without errors", i <- sample(nobs, 1) prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) - pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random", - randomized = NULL) + pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random") expect_equal(length(pred), ns) pred <- brms:::posterior_predict_beta_binomial(i, prep = prep) @@ -160,7 +159,7 @@ test_that("posterior_predict for count and survival models runs without errors", expect_equal(length(pred), ns) prep$dpars$mu <- exp(prep$dpars$eta) - pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random", randomized = NULL) + pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random") expect_equal(length(pred), ns) pred <- brms:::posterior_predict_negbinomial(i, prep = prep) @@ -398,13 +397,11 @@ test_that("truncated posterior_predict run without errors", { prep$dpars$mu <- exp(prep$dpars$mu) prep$data <- list(ub = sample(70:80, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random", - randomized = NULL) + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random") expect_equal(dim(pred), c(ns, nobs)) prep$data <- list(lb = rep(0, nobs), ub = sample(70:75, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random", - randomized = NULL) + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random") expect_equal(dim(pred), c(ns, nobs)) }) @@ -455,14 +452,12 @@ test_that("posterior_predict_gaussian runs with various 'output' values without expect_equal(length(rpred), S) # compute PIT values (q = prep$data$Y[i]) - PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability", - randomized = NULL) + PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") expect_equal(length(PITs), S) expect_true(all(PITs >= 0 & PITs <= 1)) # compute cdf based on custom 'q' - qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability", - randomized = NULL) + qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred), S) expect_false(all(PITs == qpred)) expect_true(all(qpred >= 0 & qpred <= 1)) @@ -518,14 +513,12 @@ test_that("posterior_predict_student runs with various 'output' values without e expect_equal(length(rpred), ns) # compute PIT values (q = prep$data$Y[i]) - PITs <- brms:::posterior_predict_student(i, prep = prep, output = "probability", - randomized = NULL) + PITs <- brms:::posterior_predict_student(i, prep = prep, output = "probability") expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) # compute cdf based on custom 'q' - qpred <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability", - randomized = NULL) + qpred <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred), ns) expect_false(all(PITs == qpred)) expect_true(all(qpred >= 0 & qpred <= 1)) @@ -538,14 +531,12 @@ test_that("posterior_predict_student runs with various 'output' values without e expect_true(all(rpred >= prep$data$lb[i] & rpred <= prep$data$ub[i])) # compute PIT values for truncated t (q = prep$data$Y[i]) - PITs_trunc <- brms:::posterior_predict_student(i, prep = prep, output = "probability", - randomized = NULL) + PITs_trunc <- brms:::posterior_predict_student(i, prep = prep, output = "probability") expect_equal(length(PITs_trunc), ns) expect_false(all(PITs == PITs_trunc)) # compute cdf for truncated t based on custom 'q' - qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability", - randomized = NULL) + qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred_trunc), ns) expect_false(all(qpred == qpred_trunc)) }) @@ -569,16 +560,16 @@ test_that("posterior_predict_binomial works for different 'output' values withou Y = rbinom(nobs, size = trials, prob = prep$dpars$mu) ) # random draws from binomial - pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random", randomized = NULL) + pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random") expect_equal(length(pred), ns) # compute PIT values (q = prep$data$trials[i]) - PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "probability", randomized = TRUE) + PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "pit") expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) # compute PIT values for custom 'q' (e.g., q = 5) - qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "probability", randomized = TRUE) + qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "pit") expect_equal(length(qpred), ns) expect_true(all(qpred >= 0 & qpred <= 1)) expect_false(all(PITs == qpred)) @@ -599,13 +590,10 @@ test_that("posterior_predict_poisson works for different 'output' values without ) i <- 4 - pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random", - randomized = NULL) + pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random") expect_equal(length(pred), ns) - PITs <- posterior_predict_poisson( - i, prep = prep, output = "probability", randomized = TRUE - ) + PITs <- posterior_predict_poisson(i, prep = prep, output = "pit") expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) @@ -613,8 +601,7 @@ test_that("posterior_predict_poisson works for different 'output' values without prep$data$lb <- replicate(nobs, 1) prep$data$ub <- replicate(nobs, 6) - rpred_trunc <- posterior_predict_poisson(i, prep = prep, output = "random", ntrys = 1000, - randomized = NULL) + rpred_trunc <- posterior_predict_poisson(i, prep = prep, output = "random", ntrys = 1000) # check whether invalid draws were returned # in case of invalid draws, the corresponding draw is a double and not an integer # this implementation is not ideal when posterior_predict is used by developers outside brms @@ -623,7 +610,7 @@ test_that("posterior_predict_poisson works for different 'output' values without expect_equal(length(rpred_trunc), ns) expect_true(all(rpred_trunc >= prep$data$lb[i] & rpred_trunc <= prep$data$ub[i])) - PITs_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "probability", randomized = TRUE) + PITs_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "pit") expect_equal(length(PITs_trunc), ns) expect_true(all(PITs_trunc >= 0 & PITs_trunc <= 1)) }) @@ -633,13 +620,13 @@ test_that("compute_cdf returns correct CDF for non-truncated distributions", { q <- 3 args <- list(lambda = 5) out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = NULL, ub = NULL, - randomized = NULL) + randomized = FALSE) expect_equal(out, ppois(q, lambda = 5)) q <- 2 args <- list(size = 10, prob = 0.5) out <- brms:::compute_cdf(q = q, pdist = "pbinom", args = args, lb = NULL, ub = NULL, - randomized = NULL) + randomized = FALSE) expect_equal(out, pbinom(q, size = 10, prob = 0.5)) }) diff --git a/vignettes/brms_posterior_predict.Rmd b/vignettes/brms_posterior_predict.Rmd index 2a1a8ed77..6f16785e4 100644 --- a/vignettes/brms_posterior_predict.Rmd +++ b/vignettes/brms_posterior_predict.Rmd @@ -45,14 +45,14 @@ n <- 200 ```{r binom1-fit, include = FALSE} set.seed(42) -beta0 <- -1 -beta1 <- 0.8 +beta0 <- -1 +beta1 <- 0.8 dat_binom <- dplyr::tibble( x = rnorm(n), size = sample(10:30, n, replace = TRUE), y = rbinom(n, size = size, prob = plogis(beta0 + beta1 * x)) - ) +) fit_binom_calibrated <- brms::brm( formula = "y | trials(size) ~ x", @@ -65,25 +65,25 @@ fit_binom_calibrated <- brms::brm( ```{r binom1-dens} bayesplot::ppc_bars( - y = dat_binom$y, + y = dat_binom$y, yrep = posterior_predict(fit_binom_calibrated) - ) +) ``` ```{r binom1-ecdf-random} -PITs = posterior_predict( +PITs <- posterior_predict( fit_binom_calibrated, output = "probability" - ) -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + - labs(title = "Binomial model with randomized PIT") +) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Binomial model with standard CDF") ``` ```{r binom1-ecdf} -PITs = posterior_predict( - fit_binom_calibrated, output = "probability", randomized = FALSE - ) -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + - labs(title = "Binomial model with non-randomized PIT") +PITs <- posterior_predict( + fit_binom_calibrated, output = "pit" +) +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + + labs(title = "Binomial model with randomized PIT") ``` ### Miscalibrated @@ -119,15 +119,15 @@ PITs = posterior_predict( fit_binom_miscalibrated, output = "probability" ) bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + - labs(title = "Binomial model with randomized PIT \n(miscalibrated)") + labs(title = "Binomial model with standard CDF \n(miscalibrated)") ``` ```{r binom2-ecdf} PITs = posterior_predict( - fit_binom_miscalibrated, output = "probability", randomized = FALSE + fit_binom_miscalibrated, output = "pit" ) bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + - labs(title = "Binomial model with non-randomized PIT \n(miscalibrated)") + labs(title = "Binomial model with randomized PIT \n(miscalibrated)") ``` ## Poisson @@ -152,25 +152,23 @@ fit_pois <- brm( ```{r pois-dens} bayesplot::ppc_bars( - y = dat_pois$y, + y = dat_pois$y, yrep = posterior_predict(fit_pois) ) ``` ```{r pois-ecdf-random} -PITs = posterior_predict( - fit_pois, output = "probability" - ) +PITs = posterior_predict(fit_pois, output = "pit") + bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + labs(title = "Poisson model with randomized PIT") ``` ```{r pois-ecdf} -PITs = posterior_predict( - fit_pois, output = "probability", randomized = FALSE - ) +PITs = posterior_predict(fit_pois, output = "probability") + bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + - labs(title = "Poisson model with non-randomized PIT") + labs(title = "Poisson model with standard CDF") ``` ## Normal @@ -201,6 +199,11 @@ PITs = posterior_predict(fit_norm, output = "probability") bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) ``` +```{r norm-ecdf} +PITs = posterior_predict(fit_norm, output = "pit") +bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) +``` + ## Student-t ```{r t-fit, include = FALSE} From 5a03d33f3d8175bd3058afdc513c23bb8ad10be9 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 16 Mar 2026 12:49:03 +0200 Subject: [PATCH 19/63] simplify switch case --- R/posterior_predict.R | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 7d2bca594..6c34f4c0c 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1178,14 +1178,7 @@ predict_continuous_helper <- function( ub <- prep$data$ub[i] switch(output, - "probability" = { - if (is.null(q)) { - q <- prep$data$Y[i] - } - pcontinuous( - q = q, dist = dist, lb = lb, ub = ub, ... - ) - }, + "probability" = , "pit" = { if (is.null(q)) { q <- prep$data$Y[i] From 7220a6d902b54e8b147d6805c666ee6367126893 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 23 Mar 2026 08:58:13 +0200 Subject: [PATCH 20/63] adjust code style --- R/posterior_predict.R | 29 +++++--- vignettes/brms_posterior_predict.Rmd | 106 ++++++++++++++------------- 2 files changed, 72 insertions(+), 63 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 6c34f4c0c..846aa1fa6 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -104,7 +104,7 @@ posterior_predict.brmsfit <- function( posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE, + negative_rt = negative_rt, cores = cores, summary = FALSE, output = output ) } @@ -133,8 +133,10 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, output <- as_one_character(output) if (!output %in% c("random", "probability", "pit")) { - stop2("Argument 'output' must be one of ", - "'random', 'probability', or 'pit'.") + stop2( + "Argument 'output' must be one of ", + "'random', 'probability', or 'pit'." + ) } summary <- as_one_logical(summary) @@ -267,7 +269,7 @@ predict.brmsfit <- function( transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, - robust = FALSE, probs = c(0.025, 0.975), + robust = FALSE, probs = c(0.025, 0.975), output = "random", ... ) { contains_draws(object) @@ -332,7 +334,7 @@ validate_pp_method <- function(method) { method } -# ------------------- family specific posterior_predict methods --------------------- +# ------------------- family specific posterior_predict methods ------------ # All posterior_predict_ functions have the same arguments structure # @param i index of the observation for which to compute pp values # @param prep A named list returned by prepare_predictions containing @@ -1009,7 +1011,7 @@ posterior_predict_mixture <- function(i, prep, ...) { # @return vector of random values prep from the distribution rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { args <- validate_args(dist, ...) - + if (is.null(lb) && is.null(ub)) { rdist <- paste0("r", dist) # sample as usual @@ -1096,7 +1098,7 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { # @param dist name of a distribution for which the functions # @param ... additional arguments passed to the distribution functions # @param randomized logical indicating whether to use the randomized PIT. -# @param lb optional lower truncation bound (inclusive) +# @param lb optional lower truncation bound # @param ub optional upper truncation bound # @return a vector of probability values pdiscrete <- function(q, dist, ..., randomized, lb, ub) { @@ -1161,14 +1163,16 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { round(x) } -# predict random numbers or probability / PIT values from continuous distributions +# predict random numbers or probability / PIT values from +# continuous distributions # @param output "random", "probability", or "pit" (treated as "probability") # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws # @param i index of the observation for which to compute pp values # @param dist name of the distribution # @param ntrys number of trys in rejection sampling for truncated models -# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] +# @param q optional custom quantile value; if NULL, the default is +# prep$data$Y[i] # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_continuous_helper <- function( @@ -1189,7 +1193,7 @@ predict_continuous_helper <- function( }, "random" = { rcontinuous( - n = prep$ndraws, dist = dist, lb = lb, ub = ub, + n = prep$ndraws, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... ) } @@ -1203,7 +1207,8 @@ predict_continuous_helper <- function( # @param i index of the observation for which to compute pp values # @param dist name of the distribution # @param ntrys number of trys in rejection sampling for truncated models -# @param q optional custom quantile value; if NULL, the default is prep$data$Y[i] +# @param q optional custom quantile value; if NULL, the default is +# prep$data$Y[i] # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_discrete_helper <- function( @@ -1281,4 +1286,4 @@ validate_args <- function(dist, ...) { } args -} \ No newline at end of file +} diff --git a/vignettes/brms_posterior_predict.Rmd b/vignettes/brms_posterior_predict.Rmd index 6f16785e4..ee02faf98 100644 --- a/vignettes/brms_posterior_predict.Rmd +++ b/vignettes/brms_posterior_predict.Rmd @@ -45,8 +45,8 @@ n <- 200 ```{r binom1-fit, include = FALSE} set.seed(42) -beta0 <- -1 -beta1 <- 0.8 +beta0 <- -1 +beta1 <- 0.8 dat_binom <- dplyr::tibble( x = rnorm(n), @@ -71,26 +71,28 @@ bayesplot::ppc_bars( ``` ```{r binom1-ecdf-random} -PITs <- posterior_predict( - fit_binom_calibrated, output = "probability" +pits <- posterior_predict( + fit_binom_calibrated, + output = "probability" ) -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Binomial model with standard CDF") ``` ```{r binom1-ecdf} -PITs <- posterior_predict( - fit_binom_calibrated, output = "pit" +pits <- posterior_predict( + fit_binom_calibrated, + output = "pit" ) -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Binomial model with randomized PIT") ``` ### Miscalibrated ```{r binom2-fit, include=FALSE} -phi <- 2 +phi <- 2 alpha <- phi * 0.3 -beta <- phi * (1 - 0.3) +beta <- phi * (1 - 0.3) dat_overdisp <- dplyr::tibble( x = rnorm(n), @@ -100,46 +102,48 @@ dat_overdisp <- dplyr::tibble( fit_binom_miscalibrated <- brms::brm( formula = "y | trials(size) ~ x", - data = dat_overdisp, - family = binomial(link = "logit"), - chains = 2, + data = dat_overdisp, + family = binomial(link = "logit"), + chains = 2, seed = 42 ) ``` ```{r binom2-dens} bayesplot::ppc_bars( - y = dat_overdisp$y, + y = dat_overdisp$y, yrep = posterior_predict(fit_binom_miscalibrated) - ) +) ``` ```{r binom2-ecdf-random} -PITs = posterior_predict( - fit_binom_miscalibrated, output = "probability" - ) -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + +pits <- posterior_predict( + fit_binom_miscalibrated, + output = "probability" +) +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Binomial model with standard CDF \n(miscalibrated)") ``` ```{r binom2-ecdf} -PITs = posterior_predict( - fit_binom_miscalibrated, output = "pit" - ) -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + +pits <- posterior_predict( + fit_binom_miscalibrated, + output = "pit" +) +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Binomial model with randomized PIT \n(miscalibrated)") ``` ## Poisson ```{r pois-fit, include = FALSE} -beta0 <- 0.5 -beta1 <- 0.8 +beta0 <- 0.5 +beta1 <- 0.8 dat_pois <- dplyr::tibble( x = rnorm(n), y = rpois(n, lambda = exp(beta0 + beta1 * x)) - ) +) fit_pois <- brm( formula = "y ~ x", @@ -154,54 +158,54 @@ fit_pois <- brm( bayesplot::ppc_bars( y = dat_pois$y, yrep = posterior_predict(fit_pois) - ) +) ``` ```{r pois-ecdf-random} -PITs = posterior_predict(fit_pois, output = "pit") +pits <- posterior_predict(fit_pois, output = "pit") -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Poisson model with randomized PIT") ``` ```{r pois-ecdf} -PITs = posterior_predict(fit_pois, output = "probability") +pits <- posterior_predict(fit_pois, output = "probability") -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Poisson model with standard CDF") ``` ## Normal ```{r norm-fit, include = FALSE} -dat_normal <- dplyr::tibble( +dat_normal <- dplyr::tibble( y = rnorm(n, mean = 1.0, sd = 0.8) - ) +) fit_norm <- brm( formula = "y ~ 1", - data = dat_normal, - family = gaussian(), - chains = 2, + data = dat_normal, + family = gaussian(), + chains = 2, seed = 42 ) ``` ```{r norm-dens} bayesplot::ppc_dens_overlay( - y = dat_normal$y, + y = dat_normal$y, yrep = posterior_predict(fit_norm) - ) +) ``` ```{r norm-ecdf} -PITs = posterior_predict(fit_norm, output = "probability") -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) +pits <- posterior_predict(fit_norm, output = "probability") +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) ``` ```{r norm-ecdf} -PITs = posterior_predict(fit_norm, output = "pit") -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) +pits <- posterior_predict(fit_norm, output = "pit") +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) ``` ## Student-t @@ -209,25 +213,25 @@ bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) ```{r t-fit, include = FALSE} dat_student <- dplyr::tibble( y = rt(n, df = 5) - ) +) fit_student <- brm( formula = "y ~ 1", - data = dat_student, - family = student(), - chains = 2, + data = dat_student, + family = student(), + chains = 2, seed = 42 ) ``` ```{r t-dens} bayesplot::ppc_dens_overlay( - y = dat_student$y, + y = dat_student$y, yrep = posterior_predict(fit_student) - ) +) ``` ```{r t-ecdf} -PITs = posterior_predict(fit_student, output = "probability") -bayesplot::ppc_pit_ecdf(pit = colMeans(PITs)) -``` \ No newline at end of file +pits <- posterior_predict(fit_student, output = "probability") +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) +``` From cad4b8ed9c13f6fbd96907df5d36ae0125d7bf0c Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 8 Apr 2026 10:05:46 +0300 Subject: [PATCH 21/63] refactor: remove unnessary wrapper --- R/posterior_predict.R | 61 +++++------------------- tests/testthat/tests.posterior_predict.R | 24 ++++------ 2 files changed, 21 insertions(+), 64 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 846aa1fa6..686be02ca 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1037,27 +1037,6 @@ rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } -# probability values from (possibly truncated) continuous distributions -# @param q quantile value(s) for which to compute the CDF -# @param dist name of a distribution for which the functions -# @param ... additional arguments passed to the distribution functions -# @param randomized logical indicating whether to use the randomized PIT. -# For continuous distributions, this is always FALSE; thus computes -# standard cdf value. -# @param lb optional lower truncation bound -# @param ub optional upper truncation bound -# @return a vector of probability values -# @noRd -pcontinuous <- function(q, dist, ..., randomized = FALSE, lb, ub) { - args <- validate_args(dist, ...) - pdist <- paste0("p", dist) - - compute_cdf( - q = q, pdist = pdist, args = args, lb = lb, ub = ub, - randomized = randomized - ) -} - # random numbers from (possibly truncated) discrete distributions # currently rejection sampling is used for truncated distributions # @param n number of random values to generate @@ -1091,26 +1070,6 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { out } -# probability values from (possibly truncated) discrete distributions -# Note: lb and ub are treated as inclusive in order to be consistent with the -# behavior of rdiscrete. -# @param q quantile value(s) for which to compute the CDF -# @param dist name of a distribution for which the functions -# @param ... additional arguments passed to the distribution functions -# @param randomized logical indicating whether to use the randomized PIT. -# @param lb optional lower truncation bound -# @param ub optional upper truncation bound -# @return a vector of probability values -pdiscrete <- function(q, dist, ..., randomized, lb, ub) { - args <- validate_args(dist, ...) - pdist <- paste0("p", dist) - - compute_cdf( - q = q, pdist = pdist, args = args, lb = lb, ub = ub, - randomized = randomized - ) -} - # sample from the IDs of the mixture components sample_mixture_ids <- function(theta) { stopifnot(is.matrix(theta)) @@ -1187,8 +1146,8 @@ predict_continuous_helper <- function( if (is.null(q)) { q <- prep$data$Y[i] } - pcontinuous( - q = q, dist = dist, lb = lb, ub = ub, ... + compute_cdf( + q = q, dist = dist, lb = lb, ub = ub, randomized = FALSE, ... ) }, "random" = { @@ -1222,16 +1181,16 @@ predict_discrete_helper <- function( if (is.null(q)) { q <- prep$data$Y[i] } - pdiscrete( - q = q, dist = dist, randomized = FALSE, lb = lb, ub = ub, ... + compute_cdf( + q = q, dist = dist, lb = lb, ub = ub, randomized = FALSE, ... ) }, "pit" = { if (is.null(q)) { q <- prep$data$Y[i] } - pdiscrete( - q = q, dist = dist, randomized = TRUE, lb = lb, ub = ub, ... + compute_cdf( + q = q, dist = dist, lb = lb, ub = ub, randomized = TRUE, ... ) }, "random" = { @@ -1245,14 +1204,16 @@ predict_discrete_helper <- function( # compute cdf dependent on whether the distribution is truncated or not # and whether to use the randomized PIT # @param q quantile value(s) for which to compute the CDF -# @param pdist name of the distribution function -# @param args additional arguments passed to the distribution functions +# @param dist name of a distribution for which the functions # @param lb optional lower truncation bound # @param ub optional upper truncation bound # @param randomized logical indicating whether to use the randomized PIT +# @param ... additional arguments passed to the distribution functions # @return a vector of probability values # @noRd -compute_cdf <- function(q, pdist, args, lb, ub, randomized) { +compute_cdf <- function(q, dist, lb, ub, randomized, ...) { + args <- validate_args(dist, ...) + pdist <- paste0("p", dist) # prepare computation of (non-)truncated cdf F_internal <- function(q) { if (is.null(lb) && is.null(ub)) { diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 36dae091e..7581fa337 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -618,22 +618,20 @@ test_that("posterior_predict_poisson works for different 'output' values without test_that("compute_cdf returns correct CDF for non-truncated distributions", { # Non-truncated, non-randomized: raw CDF F(q) q <- 3 - args <- list(lambda = 5) - out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = NULL, ub = NULL, - randomized = FALSE) + out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, + randomized = FALSE, lambda = 5) expect_equal(out, ppois(q, lambda = 5)) q <- 2 - args <- list(size = 10, prob = 0.5) - out <- brms:::compute_cdf(q = q, pdist = "pbinom", args = args, lb = NULL, ub = NULL, - randomized = FALSE) + out <- brms:::compute_cdf(q = q, dist = "binom", lb = NULL, ub = NULL, + randomized = FALSE, size = 10, prob = 0.5) expect_equal(out, pbinom(q, size = 10, prob = 0.5)) }) test_that("compute_cdf with randomized = FALSE returns value in [0, 1]", { q <- 5 - args <- list(lambda = 3) - out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = NULL, ub = NULL, randomized = FALSE) + out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, + randomized = FALSE, lambda = 3) expect_true(out >= 0 && out <= 1) }) @@ -641,11 +639,11 @@ test_that("compute_cdf with randomized = TRUE returns value in [F(q-1), F(q)]", # Randomized PIT: F(y-1) + V * [F(y) - F(y-1)] with V ~ Unif(0,1) set.seed(42) q <- 5 - args <- list(lambda = 3) Fq <- ppois(q, lambda = 3) Fqm1 <- ppois(q - 1, lambda = 3) - out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = NULL, ub = NULL, randomized = TRUE) + out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, randomized = TRUE, + lambda = 3) expect_true(out >= Fqm1) expect_true(out <= Fq) }) @@ -653,14 +651,13 @@ test_that("compute_cdf with randomized = TRUE returns value in [F(q-1), F(q)]", test_that("compute_cdf with randomized = TRUE and truncation returns value in valid range", { set.seed(123) q <- 4 - args <- list(lambda = 5) lb <- 2 ub <- 7 denom <- ppois(ub, lambda = 5) - ppois(lb, lambda = 5) Fq <- (ppois(q, lambda = 5) - ppois(lb, lambda = 5)) / denom Fqm1 <- (ppois(q - 1, lambda = 5) - ppois(lb, lambda = 5)) / denom - out <- brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = lb, ub = ub, randomized = TRUE) + out <- brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, randomized = TRUE, lambda = 5) expect_true(out >= Fqm1) expect_true(out <= Fq) expect_true(out >= 0 && out <= 1) @@ -668,12 +665,11 @@ test_that("compute_cdf with randomized = TRUE and truncation returns value in va test_that("compute_cdf handles zero denominator (lb == ub) without unexpected behaviour", { q <- 3 - args <- list(lambda = 2) lb <- 1 ub <- 1 out <- tryCatch( - brms:::compute_cdf(q = q, pdist = "ppois", args = args, lb = lb, ub = ub, randomized = FALSE), + brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, randomized = FALSE, lambda = 2), error = function(e) structure(list(error = TRUE, message = e$message)) ) From 462cc303ca25b2f6ae82d84747c287d1377b9a9e Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 13 Apr 2026 11:48:41 +0300 Subject: [PATCH 22/63] chore: update .gitignore to include skills --- .gitignore | 6 ------ 1 file changed, 6 deletions(-) diff --git a/.gitignore b/.gitignore index 27686264c..15d118162 100644 --- a/.gitignore +++ b/.gitignore @@ -24,9 +24,3 @@ ignore_*/ *.tmp *.swp *~ - -# Ignore agent skills -.agent/ -.agents/ -skills/ -skills-lock.json From 6cdf33b36d4d487196875227bc180124eba0f089 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 13 Apr 2026 11:49:42 +0300 Subject: [PATCH 23/63] build(deps): remove truncnorm and dplyr from Suggests --- DESCRIPTION | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index cf4ba8227..6f21ceef3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -61,8 +61,6 @@ Suggests: priorsense (>= 1.0.0), shinystan (>= 2.4.0), splines2 (>= 0.5.0), - truncnorm, - dplyr, RWiener, rtdists, extraDistr, @@ -93,14 +91,14 @@ Description: Fit Bayesian generalized (non-)linear multivariate multilevel model linear, robust linear, count data, survival, response times, ordinal, zero-inflated, hurdle, and even self-defined mixture models all in a multilevel context. Further modeling options include both theory-driven and - data-driven non-linear terms, auto-correlation structures, censoring and - truncation, meta-analytic standard errors, and quite a few more. - In addition, all parameters of the response distribution can be predicted - in order to perform distributional regression. Prior specifications are + data-driven non-linear terms, auto-correlation structures, censoring and + truncation, meta-analytic standard errors, and quite a few more. + In addition, all parameters of the response distribution can be predicted + in order to perform distributional regression. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their prior knowledge. Models can easily be evaluated and - compared using several methods assessing posterior or prior predictions. - References: Bürkner (2017) ; + compared using several methods assessing posterior or prior predictions. + References: Bürkner (2017) ; Bürkner (2018) ; Bürkner (2021) ; Carpenter et al. (2017) . From ef2520f7447f9fa3fae79ca22ac1db7ebd7cbf0e Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 13 Apr 2026 11:50:41 +0300 Subject: [PATCH 24/63] docs: update vignette for posterior_predict to use data.frame instead of tibble --- vignettes/brms_posterior_predict.Rmd | 35 ++++++++++++---------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/vignettes/brms_posterior_predict.Rmd b/vignettes/brms_posterior_predict.Rmd index ee02faf98..012ada593 100644 --- a/vignettes/brms_posterior_predict.Rmd +++ b/vignettes/brms_posterior_predict.Rmd @@ -1,6 +1,6 @@ --- title: "Using `posterior_predict` with varying output values" -author: "TODO" +author: "brms team" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: @@ -34,7 +34,6 @@ opts_chunk$set( library(ggplot2) devtools::load_all() library(extraDistr) -library(dplyr) theme_set(theme_default()) n <- 200 @@ -48,11 +47,10 @@ set.seed(42) beta0 <- -1 beta1 <- 0.8 -dat_binom <- dplyr::tibble( - x = rnorm(n), - size = sample(10:30, n, replace = TRUE), - y = rbinom(n, size = size, prob = plogis(beta0 + beta1 * x)) -) +dat_binom <- data.frame(x = rnorm(n)) +dat_binom$size <- sample(10:30, n, replace = TRUE) +dat_binom$y <- rbinom(n, size = dat_binom$size, + prob = plogis(beta0 + beta1 * dat_binom$x)) fit_binom_calibrated <- brms::brm( formula = "y | trials(size) ~ x", @@ -94,11 +92,10 @@ phi <- 2 alpha <- phi * 0.3 beta <- phi * (1 - 0.3) -dat_overdisp <- dplyr::tibble( - x = rnorm(n), - size = sample(10:30, n, replace = TRUE), - y = rbbinom(n, size = size, alpha = alpha, beta = beta) -) +dat_overdisp <- data.frame(x = rnorm(n)) +dat_overdisp$size <- sample(10:30, n, replace = TRUE) +dat_overdisp$y <- rbbinom(n, size = dat_overdisp$size, alpha = alpha, + beta = beta) fit_binom_miscalibrated <- brms::brm( formula = "y | trials(size) ~ x", @@ -140,10 +137,8 @@ bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + beta0 <- 0.5 beta1 <- 0.8 -dat_pois <- dplyr::tibble( - x = rnorm(n), - y = rpois(n, lambda = exp(beta0 + beta1 * x)) -) +dat_pois <- data.frame(x = rnorm(n)) +dat_pois$y <- rpois(n, lambda = exp(beta0 + beta1 * dat_pois$x)) fit_pois <- brm( formula = "y ~ x", @@ -178,7 +173,7 @@ bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + ## Normal ```{r norm-fit, include = FALSE} -dat_normal <- dplyr::tibble( +dat_normal <- data.frame( y = rnorm(n, mean = 1.0, sd = 0.8) ) @@ -198,12 +193,12 @@ bayesplot::ppc_dens_overlay( ) ``` -```{r norm-ecdf} +```{r norm-ecdf-probability} pits <- posterior_predict(fit_norm, output = "probability") bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) ``` -```{r norm-ecdf} +```{r norm-ecdf-pit} pits <- posterior_predict(fit_norm, output = "pit") bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) ``` @@ -211,7 +206,7 @@ bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) ## Student-t ```{r t-fit, include = FALSE} -dat_student <- dplyr::tibble( +dat_student <- data.frame( y = rt(n, df = 5) ) From ed6df11e9b88cae515fdf6395640a5d38976c408 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 13 Apr 2026 11:52:26 +0300 Subject: [PATCH 25/63] tests: remove truncnorm dependency and explicit naming of default values --- tests/testthat/tests.posterior_predict.R | 50 +++++++++++++----------- 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 7581fa337..7ede3ca6a 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -10,10 +10,10 @@ test_that("posterior_predict for location shift models runs without errors", { ) i <- sample(nobs, 1) - pred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") + pred <- brms:::posterior_predict_gaussian(i, prep = prep) expect_equal(length(pred), ns) - pred <- brms:::posterior_predict_student(i, prep = prep, output = "random") + pred <- brms:::posterior_predict_student(i, prep = prep) expect_equal(length(pred), ns) }) @@ -149,7 +149,7 @@ test_that("posterior_predict for count and survival models runs without errors", i <- sample(nobs, 1) prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) - pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random") + pred <- brms:::posterior_predict_binomial(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_beta_binomial(i, prep = prep) @@ -159,7 +159,7 @@ test_that("posterior_predict for count and survival models runs without errors", expect_equal(length(pred), ns) prep$dpars$mu <- exp(prep$dpars$eta) - pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random") + pred <- brms:::posterior_predict_poisson(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_negbinomial(i, prep = prep) @@ -392,16 +392,16 @@ test_that("truncated posterior_predict run without errors", { prep$refcat <- 1 prep$data <- list(lb = sample(-(4:7), nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_gaussian, prep = prep, output = "random") + pred <- sapply(1:nobs, brms:::posterior_predict_gaussian, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$dpars$mu <- exp(prep$dpars$mu) prep$data <- list(ub = sample(70:80, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random") + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$data <- list(lb = rep(0, nobs), ub = sample(70:75, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep, output = "random") + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) expect_equal(dim(pred), c(ns, nobs)) }) @@ -455,7 +455,7 @@ test_that("posterior_predict_gaussian runs with various 'output' values without PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") expect_equal(length(PITs), S) expect_true(all(PITs >= 0 & PITs <= 1)) - + # compute cdf based on custom 'q' qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred), S) @@ -464,7 +464,6 @@ test_that("posterior_predict_gaussian runs with various 'output' values without }) test_that("truncated posterior_predict_gaussian runs with various 'output' values without error", { - skip_if_not_installed("truncnorm") set.seed(1335) ns <- 30 nobs <- 15 @@ -479,14 +478,19 @@ test_that("truncated posterior_predict_gaussian runs with various 'output' value lb = replicate(nobs, 0), ub = replicate(nobs, 10) ) - + mu <- brms:::get_dpar(prep, "mu", i = i) sigma <- brms:::get_dpar(prep, "sigma", i = i) sigma <- brms:::add_sigma_se(sigma, prep, i = i) - + # expected cdf of truncated normal + ptruncnorm <- function(q, a, b, mean, sd) { + (pnorm(q, mean, sd) - pnorm(a, mean, sd)) / + (pnorm(b, mean, sd) - pnorm(a, mean, sd)) + } # compute cdf for truncated distribution - obs_trunc_PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") - expected_PITs <- truncnorm::ptruncnorm(q = prep$data$Y[i], a = prep$data$lb[i], + obs_trunc_PITs <- brms:::posterior_predict_gaussian(i, prep = prep, + output = "probability") + expected_PITs <- ptruncnorm(q = prep$data$Y[i], a = prep$data$lb[i], b = prep$data$ub[i], mean = mu, sd = sigma) expect_equal(obs_trunc_PITs, expected_PITs) @@ -502,7 +506,7 @@ test_that("posterior_predict_student runs with various 'output' values without e prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rchisq(ns, 3), + sigma = rchisq(ns, 3), nu = rgamma(ns, 4) ) prep$data <- list(Y = rstudent_t(nobs, df = 3)) @@ -516,14 +520,14 @@ test_that("posterior_predict_student runs with various 'output' values without e PITs <- brms:::posterior_predict_student(i, prep = prep, output = "probability") expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) - + # compute cdf based on custom 'q' qpred <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred), ns) expect_false(all(PITs == qpred)) expect_true(all(qpred >= 0 & qpred <= 1)) - prep$data$lb <- replicate(nobs, 0) + prep$data$lb <- replicate(nobs, 0) prep$data$ub <- replicate(nobs, 30) # random draws from truncated t @@ -534,7 +538,7 @@ test_that("posterior_predict_student runs with various 'output' values without e PITs_trunc <- brms:::posterior_predict_student(i, prep = prep, output = "probability") expect_equal(length(PITs_trunc), ns) expect_false(all(PITs == PITs_trunc)) - + # compute cdf for truncated t based on custom 'q' qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") expect_equal(length(qpred_trunc), ns) @@ -554,7 +558,7 @@ test_that("posterior_predict_binomial works for different 'output' values withou i <- 3 prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) - + prep$data <- list( trialsb = trials, Y = rbinom(nobs, size = trials, prob = prep$dpars$mu) @@ -598,7 +602,7 @@ test_that("posterior_predict_poisson works for different 'output' values without expect_true(all(PITs >= 0 & PITs <= 1)) # truncation interval [1, 6] - prep$data$lb <- replicate(nobs, 1) + prep$data$lb <- replicate(nobs, 1) prep$data$ub <- replicate(nobs, 6) rpred_trunc <- posterior_predict_poisson(i, prep = prep, output = "random", ntrys = 1000) @@ -618,19 +622,19 @@ test_that("posterior_predict_poisson works for different 'output' values without test_that("compute_cdf returns correct CDF for non-truncated distributions", { # Non-truncated, non-randomized: raw CDF F(q) q <- 3 - out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, + out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, randomized = FALSE, lambda = 5) expect_equal(out, ppois(q, lambda = 5)) q <- 2 - out <- brms:::compute_cdf(q = q, dist = "binom", lb = NULL, ub = NULL, + out <- brms:::compute_cdf(q = q, dist = "binom", lb = NULL, ub = NULL, randomized = FALSE, size = 10, prob = 0.5) expect_equal(out, pbinom(q, size = 10, prob = 0.5)) }) test_that("compute_cdf with randomized = FALSE returns value in [0, 1]", { q <- 5 - out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, + out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, randomized = FALSE, lambda = 3) expect_true(out >= 0 && out <= 1) }) @@ -642,7 +646,7 @@ test_that("compute_cdf with randomized = TRUE returns value in [F(q-1), F(q)]", Fq <- ppois(q, lambda = 3) Fqm1 <- ppois(q - 1, lambda = 3) - out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, randomized = TRUE, + out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, randomized = TRUE, lambda = 3) expect_true(out >= Fqm1) expect_true(out <= Fq) From 45b6600bf8d55e82a14c709bb32bd10357639648 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 13 Apr 2026 11:58:25 +0300 Subject: [PATCH 26/63] style,docs: undo style changes, adjust argument checking and naming in posterior_predict --- R/posterior_predict.R | 198 +++++++++++++++++------------------------ man/predict.brmsfit.Rd | 3 +- 2 files changed, 82 insertions(+), 119 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 686be02ca..d2c2e4ce6 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -97,15 +97,12 @@ posterior_predict.brmsfit <- function( contains_draws(object) object <- restructure(object) prep <- prepare_predictions( - object, - newdata = newdata, re_formula = re_formula, resp = resp, + object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_predict( - prep, - transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE, - output = output + prep, transform = transform, sort = sort, ntrys = ntrys, + negative_rt = negative_rt, cores = cores, summary = FALSE, output = output ) } @@ -128,16 +125,8 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, summary = FALSE, robust = FALSE, probs = c(0.025, 0.975), cores = NULL, output = "random", ...) { - dots <- list(...) - dots$output <- NULL # remove output from dots to avoid passing it twice - output <- as_one_character(output) - if (!output %in% c("random", "probability", "pit")) { - stop2( - "Argument 'output' must be one of ", - "'random', 'probability', or 'pit'." - ) - } + output <- rlang::arg_match(output, values = c("random", "probability", "pit")) summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) @@ -156,11 +145,8 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, pp_fun <- paste0("posterior_predict_", object$family$fun) pp_fun <- get(pp_fun, asNamespace("brms")) N <- choose_N(object) - out <- plapply( - seq_len(N), pp_fun, - .cores = cores, prep = object, - output = output, ... - ) + out <- plapply(seq_len(N), pp_fun, .cores = cores, prep = object, + output = output, ...) if (grepl("_mv$", object$family$fun)) { out <- do_call(abind, c(out, along = 3)) out <- aperm(out, perm = c(1, 3, 2)) @@ -175,18 +161,15 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, colnames(out) <- rownames(out) <- NULL if (use_int(object$family)) { out <- check_discrete_trunc_bounds( - out, - lb = object$data$lb, ub = object$data$ub + out, lb = object$data$lb, ub = object$data$ub ) } out <- reorder_obs(out, object$old_order, sort = sort) # transform predicted response draws before summarizing them if (!is.null(transform)) { # deprecated as of brms 2.12.3 - warning2( - "Argument 'transform' is deprecated ", - "and will be removed in the future." - ) + warning2("Argument 'transform' is deprecated ", + "and will be removed in the future.") out <- do_call(transform, list(out)) } attr(out, "levels") <- object$cats @@ -243,8 +226,7 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, #' \dontrun{ #' ## fit a model #' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), -#' data = kidney, family = "exponential", init = "0" -#' ) +#' data = kidney, family = "exponential", init = "0") #' #' ## predicted responses #' pp <- predict(fit) @@ -264,24 +246,20 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, #' } #' #' @export -predict.brmsfit <- function( - object, newdata = NULL, re_formula = NULL, - transform = NULL, resp = NULL, - negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, - sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, - robust = FALSE, probs = c(0.025, 0.975), - output = "random", ... -) { +predict.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + transform = NULL, resp = NULL, + negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, + sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, + robust = FALSE, probs = c(0.025, 0.975), + output = "random", ...) { contains_draws(object) object <- restructure(object) prep <- prepare_predictions( - object, - newdata = newdata, re_formula = re_formula, resp = resp, + object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_predict( - prep, - transform = transform, ntrys = ntrys, negative_rt = negative_rt, + prep, transform = transform, ntrys = ntrys, negative_rt = negative_rt, sort = sort, cores = cores, summary = summary, robust = robust, probs = probs, output = output ) @@ -334,7 +312,7 @@ validate_pp_method <- function(method) { method } -# ------------------- family specific posterior_predict methods ------------ +# ------------------- family specific posterior_predict methods --------------------- # All posterior_predict_ functions have the same arguments structure # @param i index of the observation for which to compute pp values # @param prep A named list returned by prepare_predictions containing @@ -342,24 +320,25 @@ validate_pp_method <- function(method) { # @param ... ignored arguments # @param A vector of length prep$ndraws containing draws # from the posterior predictive distribution -posterior_predict_gaussian <- function(i, prep, output, ntrys = 5, ...) { +posterior_predict_gaussian <- function(i, prep, output = "random", ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) predict_continuous_helper( - output = output, prep = prep, i = i, ntrys = ntrys, + i = i, prep = prep, output = output, ntrys = ntrys, dist = "norm", mean = mu, sd = sigma, ... ) } -posterior_predict_student <- function(i, prep, output, ntrys = 5, ...) { +posterior_predict_student <- function(i, prep, output = "random", ntrys = 5, ...) { nu <- get_dpar(prep, "nu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) + predict_continuous_helper( - output = output, prep = prep, i = i, ntrys = ntrys, + i = i, prep = prep, output = output, ntrys = ntrys, dist = "student_t", df = nu, mu = mu, sigma = sigma, ... ) } @@ -513,12 +492,12 @@ posterior_predict_student_fcor <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_binomial <- function(i, prep, ntrys = 5, output, ...) { +posterior_predict_binomial <- function(i, prep, output = "random", ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) size <- prep$data$trials[i] predict_discrete_helper( - output = output, i = i, prep = prep, ntrys = ntrys, + i = i, prep = prep, output = output, ntrys = ntrys, dist = "binom", prob = mu, size = size, ... ) } @@ -539,12 +518,12 @@ posterior_predict_bernoulli <- function(i, prep, ...) { rbinom(length(mu), size = 1, prob = mu) } -posterior_predict_poisson <- function(i, prep, ntrys = 5, output, ...) { +posterior_predict_poisson <- function(i, prep, output = "random", ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) predict_discrete_helper( - output = output, i = i, prep = prep, ntrys = ntrys, + i = i, prep = prep, output = output, ntrys = ntrys, dist = "pois", lambda = mu, ... ) } @@ -764,10 +743,8 @@ posterior_predict_zero_inflated_asym_laplace <- function(i, prep, ntrys = 5, } posterior_predict_cox <- function(i, prep, ...) { - stop2( - "Cannot sample from the posterior predictive ", - "distribution for family 'cox'." - ) + stop2("Cannot sample from the posterior predictive ", + "distribution for family 'cox'.") } posterior_predict_hurdle_poisson <- function(i, prep, ...) { @@ -942,10 +919,8 @@ posterior_predict_logistic_normal <- function(i, prep, ...) { mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i, cor_name = "lncor") .predict <- function(s) { - rlogistic_normal(1, - mu = mu[s, ], Sigma = Sigma[s, , ], - refcat = prep$refcat - ) + rlogistic_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ], + refcat = prep$refcat) } rblapply(seq_len(prep$ndraws), .predict) } @@ -1002,27 +977,27 @@ posterior_predict_mixture <- function(i, prep, ...) { } # ------------ predict helper-functions ---------------------- -# random numbers from (possibly truncated) continuous distributions +# random numbers from (possibly truncated) continuous distributions # @param n number of random values to generate -# @param dist name of a distribution for which the functions -# p, q, and r are available +# @param distribution name of a distribution for which the functions +# p, q, and r are available # @param ... additional arguments passed to the distribution functions # @param ntrys number of trys in rejection sampling for truncated models # @return vector of random values prep from the distribution -rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- validate_args(dist, ...) +rcontinuous <- function(n, distribution, ..., lb = NULL, ub = NULL, ntrys = 5) { + args <- validate_distribution_args(distribution, ...) if (is.null(lb) && is.null(ub)) { - rdist <- paste0("r", dist) # sample as usual + rdist <- paste0("r", distribution) out <- do_call(rdist, c(list(n), args)) } else { # sample from truncated distribution - pdist <- paste0("p", dist) - qdist <- paste0("q", dist) + pdist <- paste0("p", distribution) + qdist <- paste0("q", distribution) if (!exists(pdist, mode = "function") || !exists(qdist, mode = "function")) { # use rejection sampling as CDF or quantile function are not available - out <- rdiscrete(n, dist, ..., lb = lb, ub = ub, ntrys = ntrys) + out <- rdiscrete(n, distribution, ..., lb = lb, ub = ub, ntrys = ntrys) } else { if (is.null(lb)) lb <- -Inf if (is.null(ub)) ub <- Inf @@ -1040,17 +1015,16 @@ rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { # random numbers from (possibly truncated) discrete distributions # currently rejection sampling is used for truncated distributions # @param n number of random values to generate -# @param dist name of a distribution for which the functions -# p, q, and r are available +# @param distribution name of a distribution for which the functions +# p, q, and r are available # @param ... additional arguments passed to the distribution functions # @param lb optional lower truncation bound # @param ub optional upper truncation bound # @param ntrys number of trys in rejection sampling for truncated models # @return a vector of random values draws from the distribution -rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- validate_args(dist, ...) - rdist <- paste0("r", dist) - +rdiscrete <- function(n, distribution, ..., lb = NULL, ub = NULL, ntrys = 5) { + args <- validate_distribution_args(distribution, ...) + rdist <- paste0("r", distribution) if (is.null(lb) && is.null(ub)) { # sample as usual out <- do_call(rdist, c(list(n), args)) @@ -1074,9 +1048,9 @@ rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { sample_mixture_ids <- function(theta) { stopifnot(is.matrix(theta)) mix_comp <- seq_cols(theta) - ulapply(seq_rows(theta), function(s) { + ulapply(seq_rows(theta), function(s) sample(mix_comp, 1, prob = theta[s, ]) - }) + ) } # extract the first valid predicted value per Stan sample per observation @@ -1124,79 +1098,68 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { # predict random numbers or probability / PIT values from # continuous distributions -# @param output "random", "probability", or "pit" (treated as "probability") +# @param i index of the observation for which to compute pp values # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws -# @param i index of the observation for which to compute pp values -# @param dist name of the distribution +# @param output "random", "probability", or "pit" (treated as "probability") +# @param distribution name of the distribution # @param ntrys number of trys in rejection sampling for truncated models # @param q optional custom quantile value; if NULL, the default is # prep$data$Y[i] # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_continuous_helper <- function( - output, prep, i, dist, ntrys, q = NULL, ... + i, prep, output, distribution, ntrys, q = NULL, ... ) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] + if (output %in% c("probability", "pit") && is.null(q)) q <- prep$data$Y[i] switch(output, + "random" = { + rcontinuous(n = prep$ndraws, distribution = distribution, lb = lb, + ub = ub, ntrys = ntrys, ...) + }, + # empty "probability" = , is a "fall-through", it means if the value is + # "probability", do nothing and execute the next case's code block instead. "probability" = , "pit" = { - if (is.null(q)) { - q <- prep$data$Y[i] - } - compute_cdf( - q = q, dist = dist, lb = lb, ub = ub, randomized = FALSE, ... - ) - }, - "random" = { - rcontinuous( - n = prep$ndraws, dist = dist, lb = lb, ub = ub, - ntrys = ntrys, ... - ) + compute_cdf(q = q, distribution = distribution, lb = lb, ub = ub, + randomized = FALSE, ...) } ) } # predict random numbers or probability / PIT values from discrete distributions -# @param output "random", "probability", or "pit" (treated as "probability") +# @param i index of the observation for which to compute pp values # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws -# @param i index of the observation for which to compute pp values -# @param dist name of the distribution +# @param output "random", "probability", or "pit" (treated as "probability") +# @param distribution name of the distribution # @param ntrys number of trys in rejection sampling for truncated models # @param q optional custom quantile value; if NULL, the default is # prep$data$Y[i] # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_discrete_helper <- function( - output, prep, i, dist, ntrys, q = NULL, ... + i, prep, output, distribution, ntrys, q = NULL, ... ) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] + if (output %in% c("probability", "pit") && is.null(q)) q <- prep$data$Y[i] switch(output, + "random" = { + rdiscrete(n = prep$ndraws, distribution = distribution, lb = lb, + ub = ub, ntrys = ntrys, ...) + }, "probability" = { - if (is.null(q)) { - q <- prep$data$Y[i] - } - compute_cdf( - q = q, dist = dist, lb = lb, ub = ub, randomized = FALSE, ... - ) + compute_cdf(q = q, distribution = distribution, lb = lb, ub = ub, + randomized = FALSE, ...) }, "pit" = { - if (is.null(q)) { - q <- prep$data$Y[i] - } - compute_cdf( - q = q, dist = dist, lb = lb, ub = ub, randomized = TRUE, ... - ) - }, - "random" = { - rdiscrete( - n = prep$ndraws, dist = dist, lb = lb, ub = ub, ntrys = ntrys, ... - ) + compute_cdf(q = q, distribution = distribution, lb = lb, ub = ub, + randomized = TRUE, ...) } ) } @@ -1204,16 +1167,16 @@ predict_discrete_helper <- function( # compute cdf dependent on whether the distribution is truncated or not # and whether to use the randomized PIT # @param q quantile value(s) for which to compute the CDF -# @param dist name of a distribution for which the functions +# @param distribution name of a distribution for which the functions # @param lb optional lower truncation bound # @param ub optional upper truncation bound # @param randomized logical indicating whether to use the randomized PIT # @param ... additional arguments passed to the distribution functions # @return a vector of probability values # @noRd -compute_cdf <- function(q, dist, lb, ub, randomized, ...) { - args <- validate_args(dist, ...) - pdist <- paste0("p", dist) +compute_cdf <- function(q, distribution, lb, ub, randomized, ...) { + args <- validate_distribution_args(distribution, ...) + pdist <- paste0("p", distribution) # prepare computation of (non-)truncated cdf F_internal <- function(q) { if (is.null(lb) && is.null(ub)) { @@ -1235,10 +1198,11 @@ compute_cdf <- function(q, dist, lb, ub, randomized, ...) { F_internal(q) } } + # ensure that only arguments that are accepted by the RNG are passed -validate_args <- function(dist, ...) { +validate_distribution_args <- function(distribution, ...) { args <- list(...) - rdist <- paste0("p", dist) + rdist <- paste0("p", distribution) rdist_fun <- match.fun(rdist) rdist_formals <- names(formals(rdist_fun)) diff --git a/man/predict.brmsfit.Rd b/man/predict.brmsfit.Rd index 8e51b8f63..4d217c6bb 100644 --- a/man/predict.brmsfit.Rd +++ b/man/predict.brmsfit.Rd @@ -114,8 +114,7 @@ with additional arguments for obtaining summaries of the computed draws. \dontrun{ ## fit a model fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), - data = kidney, family = "exponential", init = "0" -) + data = kidney, family = "exponential", init = "0") ## predicted responses pp <- predict(fit) From 2b364ac66cd0aa25ed9f064f012b8006b29ecf45 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 13 Apr 2026 12:14:04 +0300 Subject: [PATCH 27/63] style: undo change in indentation style in docs example --- R/posterior_predict.R | 4 +--- man/posterior_predict.brmsfit.Rd | 3 +-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index d2c2e4ce6..e662f69b6 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -58,8 +58,7 @@ #' \dontrun{ #' ## fit a model #' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), -#' data = kidney, family = "exponential", init = "0" -#' ) +#' data = kidney, family = "exponential", init = "0") #' #' ## predicted responses #' pp <- posterior_predict(fit) @@ -130,7 +129,6 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) - if (is.customfamily(object$family)) { # ensure that the method can be found during parallel execution object$family$posterior_predict <- diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index 289e4dcd4..6e90003cb 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -123,8 +123,7 @@ For truncated discrete models only: In the absence of any general \dontrun{ ## fit a model fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), - data = kidney, family = "exponential", init = "0" -) + data = kidney, family = "exponential", init = "0") ## predicted responses pp <- posterior_predict(fit) From db26e890cd2f594b83555786edec378e67a6ea89 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Tue, 14 Apr 2026 09:42:12 +0300 Subject: [PATCH 28/63] feature: update beta-binomial with new posterior_predict functionality --- R/posterior_predict.R | 17 +++++++++-------- tests/testthat/tests.posterior_predict.R | 17 +++++++++++------ 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index e662f69b6..c2e5ee711 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -500,14 +500,15 @@ posterior_predict_binomial <- function(i, prep, output = "random", ntrys = 5, .. ) } -posterior_predict_beta_binomial <- function(i, prep, ntrys = 5, ...) { - rdiscrete( - n = prep$ndraws, dist = "beta_binomial", - size = prep$data$trials[i], - mu = get_dpar(prep, "mu", i = i), - phi = get_dpar(prep, "phi", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_beta_binomial <- function(i, prep, output = "random", + ntrys = 5, ...) { + size <- prep$data$trials[i] + mu <- get_dpar(prep, "mu", i = i) + phi <- get_dpar(prep, "phi", i = i) + + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "beta_binomial", size = size, mu = mu, phi = phi, ... ) } diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 7ede3ca6a..8b3459679 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -545,7 +545,8 @@ test_that("posterior_predict_student runs with various 'output' values without e expect_false(all(qpred == qpred_trunc)) }) -test_that("posterior_predict_binomial works for different 'output' values without error", { +test_that("posterior_predict_binomial and beta_binomial works for different +'output' values without error", { ns <- 25 nobs <- 10 trials <- sample(10:30, nobs, replace = TRUE) @@ -563,20 +564,24 @@ test_that("posterior_predict_binomial works for different 'output' values withou trialsb = trials, Y = rbinom(nobs, size = trials, prob = prep$dpars$mu) ) - # random draws from binomial - pred <- brms:::posterior_predict_binomial(i, prep = prep, output = "random") - expect_equal(length(pred), ns) # compute PIT values (q = prep$data$trials[i]) PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "pit") expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) - # compute PIT values for custom 'q' (e.g., q = 5) - qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "pit") + qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, + output = "pit") expect_equal(length(qpred), ns) expect_true(all(qpred >= 0 & qpred <= 1)) expect_false(all(PITs == qpred)) + + probs <- brms:::posterior_predict_beta_binomial(i, prep = prep, + output = "probability") + expect_equal(length(probs), ns) + + PITs <- brms:::posterior_predict_beta_binomial(i, prep = prep, output = "pit") + expect_equal(length(PITs), ns) }) From 2fbcea71464d7b39d1cc75da9d0d0b56c0f1a81c Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Tue, 14 Apr 2026 09:42:59 +0300 Subject: [PATCH 29/63] docs: add beta-binomial example to posterior_predict vignette --- vignettes/brms_posterior_predict.Rmd | 41 ++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/vignettes/brms_posterior_predict.Rmd b/vignettes/brms_posterior_predict.Rmd index 012ada593..bc8a27830 100644 --- a/vignettes/brms_posterior_predict.Rmd +++ b/vignettes/brms_posterior_predict.Rmd @@ -131,6 +131,47 @@ bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Binomial model with randomized PIT \n(miscalibrated)") ``` +## Beta-Binomial + +```{r betabinom, include = FALSE} +set.seed(42) +beta0 <- -1 +beta1 <- 0.8 +phi <- 5 # overdispersion parameter (smaller = more overdispersed) + +dat_bb <- data.frame(x = rnorm(n)) +dat_bb$size <- sample(10:30, n, replace = TRUE) + +# Simulate from beta-binomial: draw p from Beta, then y | p ~ Binomial +mu <- plogis(beta0 + beta1 * dat_bb$x) # mean probability +alpha <- mu * phi +beta <- (1 - mu) * phi +p_i <- rbeta(n, shape1 = alpha, shape2 = beta) +dat_bb$y <- rbinom(n, size = dat_bb$size, prob = p_i) + +fit_bb_calibrated <- brms::brm( + formula = y | trials(size) ~ x, + data = dat_bb, + family = beta_binomial(link = "logit"), + chains = 2, + seed = 42 +) +``` + +```{r betabinom-dens} +bayesplot::ppc_bars( + y = dat_bb$y, + yrep = posterior_predict(fit_bb_calibrated) +) +``` + +```{r betabinom-ecdf-random} +pits <- posterior_predict(fit_bb_calibrated, output = "pit") + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + + labs(title = "Beta-Binomial model with randomized PIT") +``` + ## Poisson ```{r pois-fit, include = FALSE} From 49f4d976e68f84abda72ee4a99e720630c09ec5f Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Tue, 14 Apr 2026 10:35:39 +0300 Subject: [PATCH 30/63] feature: update negbinomial with new posterior_predict functionality --- R/posterior_predict.R | 24 ++++++++++++------------ tests/testthat/tests.posterior_predict.R | 23 ++++++++++++++++++----- 2 files changed, 30 insertions(+), 17 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index c2e5ee711..529a32989 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -527,29 +527,29 @@ posterior_predict_poisson <- function(i, prep, output = "random", ntrys = 5, ... ) } -posterior_predict_negbinomial <- function(i, prep, ntrys = 5, ...) { +posterior_predict_negbinomial <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- get_dpar(prep, "shape", i) shape <- multiply_dpar_rate_denom(shape, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "nbinom", - mu = mu, size = shape, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "nbinom", mu = mu, size = shape, ... ) } -posterior_predict_negbinomial2 <- function(i, prep, ntrys = 5, ...) { +posterior_predict_negbinomial2 <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) sigma <- get_dpar(prep, "sigma", i) shape <- multiply_dpar_rate_denom(1 / sigma, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "nbinom", - mu = mu, size = shape, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "nbinom", mu = mu, size = shape, ... ) } diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 8b3459679..d47832b04 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -545,7 +545,7 @@ test_that("posterior_predict_student runs with various 'output' values without e expect_false(all(qpred == qpred_trunc)) }) -test_that("posterior_predict_binomial and beta_binomial works for different +test_that("posterior_predict of binomial variants works for different 'output' values without error", { ns <- 25 nobs <- 10 @@ -565,13 +565,11 @@ test_that("posterior_predict_binomial and beta_binomial works for different Y = rbinom(nobs, size = trials, prob = prep$dpars$mu) ) - # compute PIT values (q = prep$data$trials[i]) PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "pit") expect_equal(length(PITs), ns) expect_true(all(PITs >= 0 & PITs <= 1)) - qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, - output = "pit") + qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "pit") expect_equal(length(qpred), ns) expect_true(all(qpred >= 0 & qpred <= 1)) expect_false(all(PITs == qpred)) @@ -582,8 +580,23 @@ test_that("posterior_predict_binomial and beta_binomial works for different PITs <- brms:::posterior_predict_beta_binomial(i, prep = prep, output = "pit") expect_equal(length(PITs), ns) -}) + prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta)*30 + probs <- brms:::posterior_predict_negbinomial(i, prep = prep, output = "pit") + expect_equal(length(probs), ns) + + PITs <- brms:::posterior_predict_negbinomial(i, prep = prep, + output = "probability") + expect_equal(length(PITs), ns) + + prep$dpars$sigma <- 1/prep$dpars$shape + probs <- brms:::posterior_predict_negbinomial2(i, prep = prep, output = "pit") + expect_equal(length(probs), ns) + + PITs <- brms:::posterior_predict_negbinomial2(i, prep = prep, + output = "probability") + expect_equal(length(PITs), ns) +}) test_that("posterior_predict_poisson works for different 'output' values without error", { set.seed(1386) From 12faea1fc84b10b36a49c2a44cc8b862ab8b0efb Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Tue, 14 Apr 2026 10:36:10 +0300 Subject: [PATCH 31/63] docs: add negbinomial example to posterior_predict vignette --- vignettes/brms_posterior_predict.Rmd | 73 ++++++++++++++++++++++++++++ 1 file changed, 73 insertions(+) diff --git a/vignettes/brms_posterior_predict.Rmd b/vignettes/brms_posterior_predict.Rmd index bc8a27830..d524e8ae2 100644 --- a/vignettes/brms_posterior_predict.Rmd +++ b/vignettes/brms_posterior_predict.Rmd @@ -172,6 +172,79 @@ bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Beta-Binomial model with randomized PIT") ``` +## Negative Binomial +### Parameterization with mu and shape + +```{r negbinom1, include = FALSE} +beta0 <- 0.5 +beta1 <- 0.8 +phi <- 3 + +dat_nb_shape <- data.frame(x = rnorm(n)) +dat_nb_shape$y <- rnbinom(n, + mu = exp(beta0 + beta1 * dat_nb_shape$x), + size = phi +) + +fit_nb_shape <- brm( + formula = y ~ x, + data = dat_nb_shape, + family = negbinomial(link = "log"), + chains = 2, + seed = 42 +) +``` + +```{r negbinom1-dens} +bayesplot::ppc_bars( + y = dat_nb_shape$y, + yrep = posterior_predict(fit_nb_shape) +) +``` + +```{r negbinom1-ecdf-random} +pits <- posterior_predict(fit_nb_shape, output = "pit") + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + + labs(title = "Negative-Binomial model with randomized PIT \n (mu, shape parameterization)") +``` + +### Parameterization with mu and sigma + +```{r negbinom2, include = FALSE} +beta0 <- 0.5 +beta1 <- 0.8 +sigma <- 0.5 + +dat_nb_sigma <- data.frame(x = rnorm(n)) +dat_nb_sigma$y <- rnbinom(n, + mu = exp(beta0 + beta1 * dat_nb_sigma$x), + size = 1 / sigma +) + +fit_nb_sigma <- brm( + formula = y ~ x, + data = dat_nb_sigma, + family = negbinomial2(link = "log"), + chains = 2, + seed = 42 +) +``` + +```{r negbinom2-dens} +bayesplot::ppc_bars( + y = dat_nb_sigma$y, + yrep = posterior_predict(fit_nb_sigma) +) +``` + +```{r negbinom2-ecdf-random} +pits <- posterior_predict(fit_nb_sigma, output = "pit") + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + + labs(title = "Negative-Binomial model with randomized PIT \n (mu, sigma parameterization)") +``` + ## Poisson ```{r pois-fit, include = FALSE} From c55c53874d8964760b04019c740cfbe468b5ba50 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Tue, 14 Apr 2026 10:37:57 +0300 Subject: [PATCH 32/63] chore: add packages from Suggests to dependency install GitHub Action --- .github/workflows/R-CMD-check.yaml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 5c5860dab..0fd0d9d59 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -79,6 +79,13 @@ jobs: statmod diffobj betareg + processx + digest + mirai + future.mirai + gtable + shiny + ragg - name: Build Cmdstan run: | From 50113615e8d8ddb9e663cd4ef877c1d6765119a6 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Tue, 14 Apr 2026 12:18:49 +0300 Subject: [PATCH 33/63] feature: update zero-inflated negbinomial with new posterior_predict functionality --- .github/workflows/R-CMD-check.yaml | 7 ----- R/posterior_predict.R | 17 ++++++++--- tests/testthat/tests.posterior_predict.R | 31 +++++++++++++++++++ vignettes/brms_posterior_predict.Rmd | 39 ++++++++++++++++++++++++ 4 files changed, 83 insertions(+), 11 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 0fd0d9d59..5c5860dab 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -79,13 +79,6 @@ jobs: statmod diffobj betareg - processx - digest - mirai - future.mirai - gtable - shiny - ragg - name: Build Cmdstan run: | diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 529a32989..5a0f7714c 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -845,13 +845,22 @@ posterior_predict_zero_inflated_poisson <- function(i, prep, ...) { ifelse(tmp < zi, 0L, rpois(ndraws, lambda = lambda)) } -posterior_predict_zero_inflated_negbinomial <- function(i, prep, ...) { +posterior_predict_zero_inflated_negbinomial <- function(i, prep, + output = "random", ...) { zi <- get_dpar(prep, "zi", i = i) mu <- get_dpar(prep, "mu", i = i) shape <- get_dpar(prep, "shape", i = i) - ndraws <- prep$ndraws - tmp <- runif(ndraws, 0, 1) - ifelse(tmp < zi, 0L, rnbinom(ndraws, mu = mu, size = shape)) + + if (output == "random") { + out <- predict_discrete_helper(i = i, prep = prep, output = output, + dist = "nbinom", mu = mu, size = shape, ...) + tmp <- runif(prep$ndraws, 0, 1) + out <- ifelse(tmp < zi, 0L, out) + } else { + out <- predict_discrete_helper(i = i, prep = prep, output = output, + dist = "zero_inflated_negbinomial", mu = mu, shape = shape, zi = zi, ...) + } + out } posterior_predict_zero_inflated_binomial <- function(i, prep, ...) { diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index d47832b04..d21cd9d46 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -700,4 +700,35 @@ test_that("compute_cdf handles zero denominator (lb == ub) without unexpected be } else { expect_true(is.nan(out) || is.na(out)) } +}) + +test_that("zero_inflated_negative_binomial", { + ns <- 50 + nobs <- 8 + trials <- sample(10:30, nobs, replace = TRUE) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + eta = matrix(rnorm(ns * nobs * 2), ncol = nobs * 2), + shape = rgamma(ns, 4), phi = rgamma(ns, 1), + zi = rbeta(ns, 1, 1), coi = rbeta(ns, 5, 7) + ) + prep$dpars$mu <- prep$dpars$zi*30 + prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi + y_rand <- rnbinom(ns, size = trials, mu = prep$dpars$mu) + tmp <- runif(ns, 0, 1) + prep$data <- list( + Y = ifelse(tmp < prep$dpars$zi, 0L, y_rand), + trials = trials + ) + i <- 6 + + PITs <- brms:::posterior_predict_zero_inflated_negbinomial(i, prep = prep, + output = "pit") + expect_equal(length(PITs), ns) + expect_true(all(PITs >= 0 & PITs <= 1)) + + probs <- brms:::posterior_predict_zero_inflated_negbinomial(i, prep = prep, + output = "probability") + expect_equal(length(probs), ns) + expect_true(all(probs >= 0 & probs <= 1)) }) \ No newline at end of file diff --git a/vignettes/brms_posterior_predict.Rmd b/vignettes/brms_posterior_predict.Rmd index d524e8ae2..98549aabe 100644 --- a/vignettes/brms_posterior_predict.Rmd +++ b/vignettes/brms_posterior_predict.Rmd @@ -245,6 +245,45 @@ bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + labs(title = "Negative-Binomial model with randomized PIT \n (mu, sigma parameterization)") ``` +## Zero-inflated Negative Binomial + +```{r zinb, include = FALSE} +beta0 <- 0.5 +beta1 <- 0.8 +sigma <- 0.5 +gamma0 <- -1 + +dat_zinb <- data.frame(x = rnorm(n)) +zi <- plogis(gamma0) +dat_zinb$y <- ifelse( + rbinom(n, size = 1, prob = zi) == 1, + 0, + rnbinom(n, mu = exp(beta0 + beta1 * dat_zinb$x), size = 1 / sigma) +) + +fit_zinb <- brm( + formula = bf(y ~ x, zi ~ 1), + data = dat_zinb, + family = zero_inflated_negbinomial(link = "log"), + chains = 2, + seed = 42 +) +``` + +```{r zinb-dens} +bayesplot::ppc_bars( + y = dat_zinb$y, + yrep = posterior_predict(fit_zinb) +) +``` + +```{r zinb-ecdf-random} +pits <- posterior_predict(fit_zinb, output = "pit") + +bayesplot::ppc_pit_ecdf(pit = colMeans(pits)) + + labs(title = "Zero-Inflated Negative-Binomial model with randomized PIT") +``` + ## Poisson ```{r pois-fit, include = FALSE} From ccc9cfe03822478373fc951b6dd742f6d6b8d9cb Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 15 Apr 2026 12:06:09 +0300 Subject: [PATCH 34/63] fix: pass q (quantile) as argument in posterior_predict --- R/posterior_predict.R | 7 +++++-- man/posterior_predict.brmsfit.Rd | 4 ++++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 5a0f7714c..377a77adc 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -30,6 +30,8 @@ #' \code{"probability"}, or \code{"pit"}. Defaults to \code{"random"}. #' In case of continuous distributions, \code{"probability"} is equivalent #' to \code{"pit"}. +#' @param q Custom quantile for computing probability or PIT values. It defaults +#' to NULL in which case \code{prep$data$Y[i]} is used for the quantiles. #' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, #' this argument can be set globally via the \code{mc.cores} option. #' @param ... Further arguments passed to \code{\link{prepare_predictions}} @@ -87,7 +89,7 @@ posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, - output = "random", cores = NULL, ... + output = "random", q = NULL, cores = NULL, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { @@ -101,7 +103,8 @@ posterior_predict.brmsfit <- function( ) posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE, output = output + negative_rt = negative_rt, cores = cores, summary = FALSE, output = output, + q = q ) } diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index 6e90003cb..500d0349a 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -18,6 +18,7 @@ sort = FALSE, ntrys = 5, output = "random", + q = NULL, cores = NULL, ... ) @@ -72,6 +73,9 @@ for truncated discrete models only In case of continuous distributions, \code{"probability"} is equivalent to \code{"pit"}.} +\item{q}{Custom quantile for computing probability or PIT values. It defaults +to NULL in which case \code{prep$data$Y[i]} is used for the quantiles.} + \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} From 81c4e22b472af1359d7a5e015e572302904db1cb Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 15 Apr 2026 12:42:23 +0300 Subject: [PATCH 35/63] feature: add lower.tail and log.p to compute_cdf --- R/posterior_predict.R | 18 ++++++-- man/posterior_predict.brmsfit.Rd | 2 + tests/testthat/tests.posterior_predict.R | 59 ++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 5 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 377a77adc..6097053b2 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -89,7 +89,8 @@ posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, - output = "random", q = NULL, cores = NULL, ... + output = "random", q = NULL, cores = NULL, lower.tail = TRUE, + log.p = FALSE, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { @@ -104,7 +105,7 @@ posterior_predict.brmsfit <- function( posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, negative_rt = negative_rt, cores = cores, summary = FALSE, output = output, - q = q + q = q, lower.tail = lower.tail, log.p = log.p ) } @@ -1182,10 +1183,14 @@ predict_discrete_helper <- function( # @param lb optional lower truncation bound # @param ub optional upper truncation bound # @param randomized logical indicating whether to use the randomized PIT +# @param lower.tail logical; if TRUE (default) probabilities are P(X < x) +# otherwise, P(X > x) +# @param log.p logical; if TRUE probabilities p are given as log(p) # @param ... additional arguments passed to the distribution functions # @return a vector of probability values # @noRd -compute_cdf <- function(q, distribution, lb, ub, randomized, ...) { +compute_cdf <- function(q, distribution, lb, ub, randomized, lower.tail = TRUE, + log.p = FALSE, ...) { args <- validate_distribution_args(distribution, ...) pdist <- paste0("p", distribution) # prepare computation of (non-)truncated cdf @@ -1204,10 +1209,13 @@ compute_cdf <- function(q, distribution, lb, ub, randomized, ...) { # F(y-1) + V * [F(y) - F(y-1)] with V ~ Unif(0,1) if (isTRUE(randomized)) { v <- runif(length(q)) - F_internal(q - 1) + v * (F_internal(q) - F_internal(q - 1)) + probs <- F_internal(q - 1) + v * (F_internal(q) - F_internal(q - 1)) } else if (isFALSE(randomized)) { - F_internal(q) + probs <- F_internal(q) } + if (isFALSE(lower.tail)) probs <- 1 - probs + if (isTRUE(log.p)) probs <- log(probs) + return(probs) } # ensure that only arguments that are accepted by the RNG are passed diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index 500d0349a..a92b57a69 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -20,6 +20,8 @@ output = "random", q = NULL, cores = NULL, + lower.tail = TRUE, + log.p = FALSE, ... ) } diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index d21cd9d46..b0094d176 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -731,4 +731,63 @@ test_that("zero_inflated_negative_binomial", { output = "probability") expect_equal(length(probs), ns) expect_true(all(probs >= 0 & probs <= 1)) +}) + +test_that("compute_cdf respects lower.tail and log.p", { + q <- 0.4 + mu <- 0.1 + sd <- 1.7 + + base <- brms:::compute_cdf( + q = q, distribution = "norm", lb = NULL, ub = NULL, randomized = FALSE, + lower.tail = TRUE, log.p = FALSE, + mean = mu, sd = sd + ) + + upper <- brms:::compute_cdf( + q = q, distribution = "norm", lb = NULL, ub = NULL, randomized = FALSE, + lower.tail = FALSE, log.p = FALSE, + mean = mu, sd = sd + ) + + log_base <- brms:::compute_cdf( + q = q, distribution = "norm", lb = NULL, ub = NULL, randomized = FALSE, + lower.tail = TRUE, log.p = TRUE, + mean = mu, sd = sd + ) + + log_upper <- brms:::compute_cdf( + q = q, distribution = "norm", lb = NULL, ub = NULL, randomized = FALSE, + lower.tail = FALSE, log.p = TRUE, + mean = mu, sd = sd + ) + + expected <- pnorm(q, mean = mu, sd = sd) + + expect_equal(base, expected) + expect_equal(upper, 1 - expected) + expect_equal(log_base, log(expected)) + expect_equal(log_upper, log(1 - expected)) +}) + +test_that("posterior_predict forwards lower.tail and log.p correctly", { + fit <- brms:::rename_pars(brms:::brmsfit_example3) + q_ref <- 15 + + p_lower <- posterior_predict(fit, output = "probability", q = q_ref, + lower.tail = TRUE, log.p = FALSE) + + p_upper <- posterior_predict(fit, output = "probability", q = q_ref, + lower.tail = FALSE, log.p = FALSE) + + log_lower <- posterior_predict(fit, output = "probability", q = q_ref, + lower.tail = TRUE, log.p = TRUE) + + log_upper <- posterior_predict(fit, output = "probability", q = q_ref, + lower.tail = FALSE, log.p = TRUE) + + expect_equal(dim(p_lower), dim(p_upper)) + expect_equal(p_upper, 1 - p_lower) + expect_equal(log_lower, log(p_lower)) + expect_equal(log_upper, log(p_upper)) }) \ No newline at end of file From a881609644eb6e173a6d70b0f48bc70a20b7f1c3 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 15 Apr 2026 13:27:30 +0300 Subject: [PATCH 36/63] fix: remove log.p and lower.tail from 'random' --- R/posterior_predict.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 6097053b2..a79c83bb1 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1129,8 +1129,10 @@ predict_continuous_helper <- function( switch(output, "random" = { - rcontinuous(n = prep$ndraws, distribution = distribution, lb = lb, - ub = ub, ntrys = ntrys, ...) + dots <- list(...) + dots[c("log.p", "lower.tail")] <- NULL + do.call(rcontinuous, c(list(n = prep$ndraws, distribution = distribution, + lb = lb, ub = ub, ntrys = ntrys), dots)) }, # empty "probability" = , is a "fall-through", it means if the value is # "probability", do nothing and execute the next case's code block instead. @@ -1162,8 +1164,10 @@ predict_discrete_helper <- function( switch(output, "random" = { - rdiscrete(n = prep$ndraws, distribution = distribution, lb = lb, - ub = ub, ntrys = ntrys, ...) + dots <- list(...) + dots[c("log.p", "lower.tail")] <- NULL + do.call(rdiscrete, c(list(n = prep$ndraws, distribution = distribution, + lb = lb, ub = ub, ntrys = ntrys), dots)) }, "probability" = { compute_cdf(q = q, distribution = distribution, lb = lb, ub = ub, From 35833f374cc20057b54db61eca8064c131cdc182 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 15 Apr 2026 13:35:55 +0300 Subject: [PATCH 37/63] fix: set ntrys as optional in predict_discrete_helper --- R/posterior_predict.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index a79c83bb1..d5462e351 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1156,7 +1156,7 @@ predict_continuous_helper <- function( # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_discrete_helper <- function( - i, prep, output, distribution, ntrys, q = NULL, ... + i, prep, output, distribution, ntrys = NULL, q = NULL, ... ) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] From 54cfbb017ed49e2a9aae1881bd1ec81f33c62c85 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 15 Apr 2026 13:53:34 +0300 Subject: [PATCH 38/63] docs: add lower.tail and log.p documentation to posterior_predict --- R/posterior_predict.R | 5 +++++ man/posterior_predict.brmsfit.Rd | 7 +++++++ 2 files changed, 12 insertions(+) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index d5462e351..6d4f832a4 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -32,6 +32,11 @@ #' to \code{"pit"}. #' @param q Custom quantile for computing probability or PIT values. It defaults #' to NULL in which case \code{prep$data$Y[i]} is used for the quantiles. +#' @param lower.tail logical for computing probability or PIT values. It +#' defaults to TRUE in which case probabilities are P(X < x) otherwise, +#' P(X > x). +#' @param log.p logical for computing probability or PIT values. It defaults to +#' FALSE, if TRUE probabilities p are given as log(p). #' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, #' this argument can be set globally via the \code{mc.cores} option. #' @param ... Further arguments passed to \code{\link{prepare_predictions}} diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index a92b57a69..3d93ae6a8 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -81,6 +81,13 @@ to NULL in which case \code{prep$data$Y[i]} is used for the quantiles.} \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} +\item{lower.tail}{logical for computing probability or PIT values. It +defaults to TRUE in which case probabilities are P(X < x) otherwise, +P(X > x).} + +\item{log.p}{logical for computing probability or PIT values. It defaults to +FALSE, if TRUE probabilities p are given as log(p).} + \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } From 3607f7b9cc4c95e752d4cb9ca4da717362746005 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Fri, 17 Apr 2026 10:23:08 +0300 Subject: [PATCH 39/63] feature: add output 'density', 'quantile' to selected distribution families --- NAMESPACE | 2 + R/distributions.R | 45 ++ R/posterior_predict.R | 155 +++++-- man/BetaBinomial.Rd | 10 + man/ZeroInflated.Rd | 7 + man/posterior_predict.brmsfit.Rd | 25 +- man/predict.brmsfit.Rd | 6 +- .../tests.distributions_quantile_outputs.R | 67 +++ ...tests.posterior_predict_density_quantile.R | 215 ++++++++++ .../brms_distribution_output_cheatsheet.Rmd | 395 ++++++++++++++++++ 10 files changed, 886 insertions(+), 41 deletions(-) create mode 100644 tests/testthat/tests.distributions_quantile_outputs.R create mode 100644 tests/testthat/tests.posterior_predict_density_quantile.R create mode 100644 vignettes/brms_distribution_output_cheatsheet.Rmd diff --git a/NAMESPACE b/NAMESPACE index e2b820bab..0eb2c1de9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -559,11 +559,13 @@ export(pzero_inflated_binomial) export(pzero_inflated_negbinomial) export(pzero_inflated_poisson) export(qasym_laplace) +export(qbeta_binomial) export(qfrechet) export(qgen_extreme_value) export(qshifted_lnorm) export(qskew_normal) export(qstudent_t) +export(qzero_inflated_negbinomial) export(ranef) export(rasym_laplace) export(rbeta_binomial) diff --git a/R/distributions.R b/R/distributions.R index 568de23d4..220d3c4e6 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -918,6 +918,10 @@ rinv_gaussian <- function(n, mu = 1, shape = 1) { #' \item{\code{phi = (1 - mu) * beta}} precision or over-dispersion, component. #' } #' +#' The quantile function has no known closed form for this parameterization and +#' is therefore computed numerically via inversion of the cumulative +#' distribution function over the finite support \code{0:size}. +#' #' @name BetaBinomial #' #' @inheritParams StudentT @@ -944,6 +948,31 @@ pbeta_binomial <- function(q, size, mu, phi, lower.tail = TRUE, log.p = FALSE) { lower.tail = lower.tail, log.p = log.p) } +#' @rdname BetaBinomial +#' @export +qbeta_binomial <- function(p, size, mu, phi, lower.tail = TRUE, log.p = FALSE) { + require_package("extraDistr") + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- do_call(expand, nlist(p, size, mu, phi)) + out <- vapply(seq_along(args$p), function(i) { + if (!is.finite(args$p[i])) { + return(args$p[i]) + } + alpha <- args$mu[i] * args$phi[i] + beta <- (1 - args$mu[i]) * args$phi[i] + x <- 0:args$size[i] + cdf <- cumsum(extraDistr::dbbinom(x, args$size[i], alpha = alpha, beta = beta)) + ind <- which(cdf >= args$p[i])[1] + if (is.na(ind)) { + args$size[i] + } else { + x[ind] + } + }, numeric(1)) + dim(out) <- attributes(args)$max_dim + out +} + #' @rdname BetaBinomial #' @export rbeta_binomial <- function(n, size, mu, phi) { @@ -1761,6 +1790,8 @@ rxbeta <- function(...) { #' If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. #' Else set \eqn{f(x) = (1 - \theta) * g(x)}, #' where \eqn{g(x)} is the density of the non-zero-inflated part. +#' For the zero-inflated negative binomial distribution, the quantile function +#' has no known closed form and is therefore computed numerically. NULL #' @rdname ZeroInflated @@ -1793,6 +1824,20 @@ pzero_inflated_negbinomial <- function(q, mu, shape, zi, lower.tail = TRUE, .pzero_inflated(q, "nbinom", zi, pars, lower.tail, log.p) } +#' @rdname ZeroInflated +#' @export +qzero_inflated_negbinomial <- function(p, mu, shape, zi, lower.tail = TRUE, + log.p = FALSE) { + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- do_call(expand, nlist(p, mu, shape, zi)) + p_nb <- with(args, ifelse(zi == 1, 0, (p - zi) / (1 - zi))) + p_nb <- pmin(1, pmax(0, p_nb)) + out <- qnbinom(p_nb, mu = args$mu, size = args$shape) + out[!is.finite(args$p)] <- args$p[!is.finite(args$p)] + dim(out) <- attributes(args)$max_dim + out +} + #' @rdname ZeroInflated #' @export dzero_inflated_binomial <- function(x, size, prob, zi, log = FALSE) { diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 6d4f832a4..62f3aa4c2 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -27,16 +27,17 @@ #' for truncated discrete models only #' (defaults to \code{5}). See Details for more information. #' @param output The type of output to return. Can be \code{"random"}, -#' \code{"probability"}, or \code{"pit"}. Defaults to \code{"random"}. -#' In case of continuous distributions, \code{"probability"} is equivalent -#' to \code{"pit"}. -#' @param q Custom quantile for computing probability or PIT values. It defaults -#' to NULL in which case \code{prep$data$Y[i]} is used for the quantiles. -#' @param lower.tail logical for computing probability or PIT values. It -#' defaults to TRUE in which case probabilities are P(X < x) otherwise, -#' P(X > x). -#' @param log.p logical for computing probability or PIT values. It defaults to -#' FALSE, if TRUE probabilities p are given as log(p). +#' \code{"probability"}, \code{"pit"}, \code{"density"}, or +#' \code{"quantile"}. Defaults to \code{"random"}. In case of continuous +#' distributions, \code{"probability"} is equivalent to \code{"pit"}. +#' @param q Custom quantile for computing probability, PIT, or density values. +#' It defaults to NULL in which case \code{prep$data$Y[i]} is used. +#' @param p Custom probability for computing quantile values. +#' @param lower.tail logical for computing probability or quantile values. It +#' defaults to TRUE in which case probabilities are P(X < x) otherwise P(X > x). +#' @param log.p logical for computing probability or quantile values. It +#' defaults to FALSE, if TRUE probabilities p are given as log(p). +#' @param log logical for computing density values. It defaults to FALSE. #' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, #' this argument can be set globally via the \code{mc.cores} option. #' @param ... Further arguments passed to \code{\link{prepare_predictions}} @@ -94,8 +95,8 @@ posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, - output = "random", q = NULL, cores = NULL, lower.tail = TRUE, - log.p = FALSE, ... + output = "random", q = NULL, p = NULL, cores = NULL, lower.tail = TRUE, + log.p = FALSE, log = FALSE, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { @@ -110,7 +111,7 @@ posterior_predict.brmsfit <- function( posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, negative_rt = negative_rt, cores = cores, summary = FALSE, output = output, - q = q, lower.tail = lower.tail, log.p = log.p + q = q, p = p, lower.tail = lower.tail, log.p = log.p, log = log ) } @@ -134,7 +135,9 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, probs = c(0.025, 0.975), cores = NULL, output = "random", ...) { output <- as_one_character(output) - output <- rlang::arg_match(output, values = c("random", "probability", "pit")) + output <- rlang::arg_match( + output, values = c("random", "probability", "pit", "density", "quantile") + ) summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) @@ -1113,29 +1116,33 @@ check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { round(x) } -# predict random numbers or probability / PIT values from +# predict random numbers, CDF/PIT, density, or quantiles from # continuous distributions # @param i index of the observation for which to compute pp values # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws -# @param output "random", "probability", or "pit" (treated as "probability") +# @param output "random", "probability", "pit", "density", or "quantile" # @param distribution name of the distribution # @param ntrys number of trys in rejection sampling for truncated models # @param q optional custom quantile value; if NULL, the default is # prep$data$Y[i] +# @param p optional custom probability value for quantile output # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_continuous_helper <- function( - i, prep, output, distribution, ntrys, q = NULL, ... + i, prep, output, distribution, ntrys, q = NULL, p = NULL, ... ) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] - if (output %in% c("probability", "pit") && is.null(q)) q <- prep$data$Y[i] + if (output %in% c("probability", "pit", "density") && is.null(q)) q <- prep$data$Y[i] + if (output == "quantile" && is.null(p)) { + stop2("Argument 'p' must be specified when output = 'quantile'.") + } switch(output, "random" = { dots <- list(...) - dots[c("log.p", "lower.tail")] <- NULL + dots[c("log.p", "lower.tail", "log", "p")] <- NULL do.call(rcontinuous, c(list(n = prep$ndraws, distribution = distribution, lb = lb, ub = ub, ntrys = ntrys), dots)) }, @@ -1145,32 +1152,42 @@ predict_continuous_helper <- function( "pit" = { compute_cdf(q = q, distribution = distribution, lb = lb, ub = ub, randomized = FALSE, ...) + }, + "density" = { + compute_density(q = q, distribution = distribution, lb = lb, ub = ub, ...) + }, + "quantile" = { + compute_quantile(p = p, distribution = distribution, lb = lb, ub = ub, ...) } ) } -# predict random numbers or probability / PIT values from discrete distributions +# predict random numbers, CDF/PIT, density, or quantiles from discrete distributions # @param i index of the observation for which to compute pp values # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws -# @param output "random", "probability", or "pit" (treated as "probability") +# @param output "random", "probability", "pit", "density", or "quantile" # @param distribution name of the distribution # @param ntrys number of trys in rejection sampling for truncated models # @param q optional custom quantile value; if NULL, the default is # prep$data$Y[i] +# @param p optional custom probability value for quantile output # @param ... additional arguments passed to the distribution functions # @return a vector of draws predict_discrete_helper <- function( - i, prep, output, distribution, ntrys = NULL, q = NULL, ... + i, prep, output, distribution, ntrys = NULL, q = NULL, p = NULL, ... ) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] - if (output %in% c("probability", "pit") && is.null(q)) q <- prep$data$Y[i] + if (output %in% c("probability", "pit", "density") && is.null(q)) q <- prep$data$Y[i] + if (output == "quantile" && is.null(p)) { + stop2("Argument 'p' must be specified when output = 'quantile'.") + } switch(output, "random" = { dots <- list(...) - dots[c("log.p", "lower.tail")] <- NULL + dots[c("log.p", "lower.tail", "log", "p")] <- NULL do.call(rdiscrete, c(list(n = prep$ndraws, distribution = distribution, lb = lb, ub = ub, ntrys = ntrys), dots)) }, @@ -1181,6 +1198,12 @@ predict_discrete_helper <- function( "pit" = { compute_cdf(q = q, distribution = distribution, lb = lb, ub = ub, randomized = TRUE, ...) + }, + "density" = { + compute_density(q = q, distribution = distribution, lb = lb, ub = ub, ...) + }, + "quantile" = { + compute_quantile(p = p, distribution = distribution, lb = lb, ub = ub, ...) } ) } @@ -1200,7 +1223,7 @@ predict_discrete_helper <- function( # @noRd compute_cdf <- function(q, distribution, lb, ub, randomized, lower.tail = TRUE, log.p = FALSE, ...) { - args <- validate_distribution_args(distribution, ...) + args <- validate_distribution_args(distribution, fun_prefix = "p", ...) pdist <- paste0("p", distribution) # prepare computation of (non-)truncated cdf F_internal <- function(q) { @@ -1227,10 +1250,86 @@ compute_cdf <- function(q, distribution, lb, ub, randomized, lower.tail = TRUE, return(probs) } -# ensure that only arguments that are accepted by the RNG are passed -validate_distribution_args <- function(distribution, ...) { +# compute density dependent on whether the distribution is truncated or not +# @param q quantile value(s) for which to compute the density +# @param distribution name of a distribution +# @param lb optional lower truncation bound +# @param ub optional upper truncation bound +# @param log logical; if TRUE densities are given as log(d) +# @param ... additional arguments passed to the distribution functions +# @return a vector of density values +# @noRd +compute_density <- function(q, distribution, lb, ub, log = FALSE, ...) { + dargs <- validate_distribution_args(distribution, fun_prefix = "d", ...) + pargs <- validate_distribution_args(distribution, fun_prefix = "p", ...) + ddist <- paste0("d", distribution) + pdist <- paste0("p", distribution) + if (is.null(lb) && is.null(ub)) { + return(do_call(ddist, c(list(q), dargs, log = log))) + } + if (is.null(lb)) { + cdf_lb <- rep(0, length(q)) + } else { + cdf_lb <- do_call(pdist, c(list(lb), pargs)) + } + if (is.null(ub)) { + cdf_ub <- rep(1, length(q)) + } else { + cdf_ub <- do_call(pdist, c(list(ub), pargs)) + } + denom <- cdf_ub - cdf_lb + if (any(denom == 0)) stop("Division by zero") + dens <- do_call(ddist, c(list(q), dargs, log = FALSE)) / denom + if (!is.null(lb)) dens[q < lb] <- 0 + if (!is.null(ub)) dens[q > ub] <- 0 + if (isTRUE(log)) dens <- log(dens) + dens +} + +# compute quantile dependent on whether the distribution is truncated or not +# @param p probability value(s) for which to compute the quantile +# @param distribution name of a distribution +# @param lb optional lower truncation bound +# @param ub optional upper truncation bound +# @param lower.tail logical; if TRUE (default) probabilities are P(X < x) +# otherwise, P(X > x) +# @param log.p logical; if TRUE probabilities p are given as log(p) +# @param ... additional arguments passed to the distribution functions +# @return a vector of quantile values +# @noRd +compute_quantile <- function(p, distribution, lb, ub, lower.tail = TRUE, + log.p = FALSE, ...) { + qargs <- validate_distribution_args(distribution, fun_prefix = "q", ...) + pargs <- validate_distribution_args(distribution, fun_prefix = "p", ...) + qdist <- paste0("q", distribution) + pdist <- paste0("p", distribution) + if (is.null(lb) && is.null(ub)) { + return(do_call( + qdist, c(list(p), qargs, lower.tail = lower.tail, log.p = log.p) + )) + } + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + if (is.null(lb)) { + cdf_lb <- rep(0, length(p)) + } else { + cdf_lb <- do_call(pdist, c(list(lb), pargs)) + } + if (is.null(ub)) { + cdf_ub <- rep(1, length(p)) + } else { + cdf_ub <- do_call(pdist, c(list(ub), pargs)) + } + denom <- cdf_ub - cdf_lb + if (any(denom == 0)) stop("Division by zero") + p_internal <- p * denom + cdf_lb + do_call(qdist, c(list(p_internal), qargs)) +} + +# ensure that only arguments that are accepted by distribution functions are passed +validate_distribution_args <- function(distribution, fun_prefix = "p", ...) { args <- list(...) - rdist <- paste0("p", distribution) + fun_prefix <- as_one_character(fun_prefix) + rdist <- paste0(fun_prefix, distribution) rdist_fun <- match.fun(rdist) rdist_formals <- names(formals(rdist_fun)) diff --git a/man/BetaBinomial.Rd b/man/BetaBinomial.Rd index 2280b8ef4..aa2b4f5aa 100644 --- a/man/BetaBinomial.Rd +++ b/man/BetaBinomial.Rd @@ -4,6 +4,7 @@ \alias{BetaBinomial} \alias{dbeta_binomial} \alias{pbeta_binomial} +\alias{qbeta_binomial} \alias{rbeta_binomial} \title{The Beta-binomial Distribution} \usage{ @@ -11,6 +12,8 @@ dbeta_binomial(x, size, mu, phi, log = FALSE) pbeta_binomial(q, size, mu, phi, lower.tail = TRUE, log.p = FALSE) +qbeta_binomial(p, size, mu, phi, lower.tail = TRUE, log.p = FALSE) + rbeta_binomial(n, size, mu, phi) } \arguments{ @@ -29,6 +32,8 @@ Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} +\item{p}{Vector of probabilities.} + \item{n}{Number of draws to sample from the distribution.} } \description{ @@ -41,3 +46,8 @@ Beta-binomial definition}: \item{\code{phi = (1 - mu) * beta}} precision or over-dispersion, component. } } +\details{ +The quantile function has no known closed form for this parameterization and +is therefore computed numerically via inversion of the cumulative +distribution function over the finite support \code{0:size}. +} diff --git a/man/ZeroInflated.Rd b/man/ZeroInflated.Rd index 6ea1e48b2..f85ed7520 100644 --- a/man/ZeroInflated.Rd +++ b/man/ZeroInflated.Rd @@ -6,6 +6,7 @@ \alias{pzero_inflated_poisson} \alias{dzero_inflated_negbinomial} \alias{pzero_inflated_negbinomial} +\alias{qzero_inflated_negbinomial} \alias{dzero_inflated_binomial} \alias{pzero_inflated_binomial} \alias{dzero_inflated_beta_binomial} @@ -22,6 +23,8 @@ dzero_inflated_negbinomial(x, mu, shape, zi, log = FALSE) pzero_inflated_negbinomial(q, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) +qzero_inflated_negbinomial(p, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) + dzero_inflated_binomial(x, size, prob, zi, log = FALSE) pzero_inflated_binomial(q, size, prob, zi, lower.tail = TRUE, log.p = FALSE) @@ -60,6 +63,8 @@ Else, return P(X > x) .} \item{shape, shape1, shape2}{shape parameter} +\item{p}{Vector of probabilities.} + \item{size}{number of trials} \item{prob}{probability of success on each trial} @@ -74,4 +79,6 @@ The density of a zero-inflated distribution can be specified as follows. If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. Else set \eqn{f(x) = (1 - \theta) * g(x)}, where \eqn{g(x)} is the density of the non-zero-inflated part. +For the zero-inflated negative binomial distribution, the quantile function +has no known closed form and is therefore computed numerically. } diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index 3d93ae6a8..09f67b692 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -19,9 +19,11 @@ ntrys = 5, output = "random", q = NULL, + p = NULL, cores = NULL, lower.tail = TRUE, log.p = FALSE, + log = FALSE, ... ) } @@ -71,22 +73,25 @@ for truncated discrete models only (defaults to \code{5}). See Details for more information.} \item{output}{The type of output to return. Can be \code{"random"}, -\code{"probability"}, or \code{"pit"}. Defaults to \code{"random"}. -In case of continuous distributions, \code{"probability"} is equivalent -to \code{"pit"}.} +\code{"probability"}, \code{"pit"}, \code{"density"}, or +\code{"quantile"}. Defaults to \code{"random"}. In case of continuous +distributions, \code{"probability"} is equivalent to \code{"pit"}.} -\item{q}{Custom quantile for computing probability or PIT values. It defaults -to NULL in which case \code{prep$data$Y[i]} is used for the quantiles.} +\item{q}{Custom quantile for computing probability, PIT, or density values. +It defaults to NULL in which case \code{prep$data$Y[i]} is used.} + +\item{p}{Custom probability for computing quantile values.} \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} -\item{lower.tail}{logical for computing probability or PIT values. It -defaults to TRUE in which case probabilities are P(X < x) otherwise, -P(X > x).} +\item{lower.tail}{logical for computing probability or quantile values. It +defaults to TRUE in which case probabilities are P(X < x) otherwise P(X > x).} + +\item{log.p}{logical for computing probability or quantile values. It +defaults to FALSE, if TRUE probabilities p are given as log(p).} -\item{log.p}{logical for computing probability or PIT values. It defaults to -FALSE, if TRUE probabilities p are given as log(p).} +\item{log}{logical for computing density values. It defaults to FALSE.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} diff --git a/man/predict.brmsfit.Rd b/man/predict.brmsfit.Rd index 4d217c6bb..8e9c7fdd2 100644 --- a/man/predict.brmsfit.Rd +++ b/man/predict.brmsfit.Rd @@ -82,9 +82,9 @@ Only used if \code{summary} is \code{TRUE}.} function. Only used if \code{summary} is \code{TRUE}.} \item{output}{The type of output to return. Can be \code{"random"}, -\code{"probability"}, or \code{"pit"}. Defaults to \code{"random"}. -In case of continuous distributions, \code{"probability"} is equivalent -to \code{"pit"}.} +\code{"probability"}, \code{"pit"}, \code{"density"}, or +\code{"quantile"}. Defaults to \code{"random"}. In case of continuous +distributions, \code{"probability"} is equivalent to \code{"pit"}.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R new file mode 100644 index 000000000..b92aa471e --- /dev/null +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -0,0 +1,67 @@ +context("Validation tests for new discrete quantile distributions") + +test_that("qbeta_binomial satisfies the discrete quantile definition", { + skip_if_not_installed("extraDistr") + + size <- 12 + mu <- 0.35 + phi <- 8 + p <- c(0.01, 0.1, 0.5, 0.85, 0.99) + + q <- brms:::qbeta_binomial(p, size = size, mu = mu, phi = phi) + F_q <- brms:::pbeta_binomial(q, size = size, mu = mu, phi = phi) + F_qm1 <- brms:::pbeta_binomial(q - 1, size = size, mu = mu, phi = phi) + + expect_true(all(F_q >= p)) + expect_true(all(F_qm1 < p)) + expect_true(all(q >= 0 & q <= size)) +}) + +test_that("qzero_inflated_negbinomial satisfies the discrete quantile definition", { + mu <- 4 + shape <- 2.5 + zi <- 0.3 + p <- c(0.01, 0.1, 0.5, 0.85, 0.99) + + q <- brms:::qzero_inflated_negbinomial(p, mu = mu, shape = shape, zi = zi) + F_q <- brms:::pzero_inflated_negbinomial(q, mu = mu, shape = shape, zi = zi) + F_qm1 <- brms:::pzero_inflated_negbinomial(q - 1, mu = mu, shape = shape, zi = zi) + + expect_true(all(F_q >= p)) + expect_true(all(F_qm1 < p)) + expect_true(all(q >= 0)) +}) + +test_that("quantile functions are monotone in probability", { + p <- seq(0.01, 0.99, length.out = 50) + + q_bb <- brms:::qbeta_binomial(p, size = 20, mu = 0.45, phi = 6) + q_zinb <- brms:::qzero_inflated_negbinomial(p, mu = 5, shape = 2, zi = 0.25) + + expect_true(all(diff(q_bb) >= 0)) + expect_true(all(diff(q_zinb) >= 0)) +}) + +test_that("quantile functions respect lower.tail and log.p", { + p_ref <- 0.2 + + q_bb_upper <- brms:::qbeta_binomial( + p_ref, size = 20, mu = 0.45, phi = 6, + lower.tail = FALSE, log.p = FALSE + ) + q_bb_ref <- brms:::qbeta_binomial( + 1 - p_ref, size = 20, mu = 0.45, phi = 6, + lower.tail = TRUE, log.p = FALSE + ) + expect_equal(q_bb_upper, q_bb_ref) + + q_zinb_log <- brms:::qzero_inflated_negbinomial( + log(p_ref), mu = 5, shape = 2, zi = 0.25, + lower.tail = TRUE, log.p = TRUE + ) + q_zinb_ref <- brms:::qzero_inflated_negbinomial( + p_ref, mu = 5, shape = 2, zi = 0.25, + lower.tail = TRUE, log.p = FALSE + ) + expect_equal(q_zinb_log, q_zinb_ref) +}) diff --git a/tests/testthat/tests.posterior_predict_density_quantile.R b/tests/testthat/tests.posterior_predict_density_quantile.R new file mode 100644 index 000000000..8648d1d5f --- /dev/null +++ b/tests/testthat/tests.posterior_predict_density_quantile.R @@ -0,0 +1,215 @@ +context("Validation tests for posterior_predict density and quantile outputs") + +skip_if_density_quantile_not_available <- function() { + ns <- asNamespace("brms") + has_density <- exists("compute_density", envir = ns, inherits = FALSE) + has_quantile <- exists("compute_quantile", envir = ns, inherits = FALSE) + if (!(has_density && has_quantile)) { + testthat::skip("Density/quantile posterior_predict helpers are not available.") + } +} + +make_prep_gaussian <- function(ns = 120, nobs = 8) { + set.seed(1001) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rgamma(ns, shape = 4, rate = 3) + ) + prep$data <- list( + Y = rnorm(nobs), + lb = rep(NULL, nobs), + ub = rep(NULL, nobs) + ) + prep +} + +make_prep_student <- function(ns = 120, nobs = 8) { + set.seed(1002) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rgamma(ns, shape = 4, rate = 3), + nu = rgamma(ns, shape = 6, rate = 1) + 2 + ) + prep$data <- list( + Y = rnorm(nobs), + lb = rep(NULL, nobs), + ub = rep(NULL, nobs) + ) + prep +} + +make_prep_count <- function(ns = 150, nobs = 10) { + set.seed(1003) + trials <- sample(10:30, nobs, replace = TRUE) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(plogis(rnorm(ns * nobs)), ncol = nobs), + phi = rgamma(ns, shape = 5, rate = 1), + shape = rgamma(ns, shape = 4, rate = 1), + sigma = rgamma(ns, shape = 3, rate = 2), + zi = rbeta(ns, 1.5, 5) + ) + prep$data <- list( + Y = rpois(nobs, lambda = 5), + trials = trials, + lb = rep(NULL, nobs), + ub = rep(NULL, nobs) + ) + prep +} + +test_that("continuous families: density matches finite-difference CDF", { + + h <- 1e-4 + i <- 3 + q_ref <- 0.25 + + prep_g <- make_prep_gaussian() + f_g <- brms:::posterior_predict_gaussian(i, + prep = prep_g, output = "density", q = q_ref) + F_plus_g <- brms:::posterior_predict_gaussian(i, + prep = prep_g, output = "probability", q = q_ref + h) + F_minus_g <- brms:::posterior_predict_gaussian(i, + prep = prep_g, output = "probability", q = q_ref - h) + fd_g <- (F_plus_g - F_minus_g) / (2 * h) + expect_equal(f_g, fd_g, tolerance = 1e-3) + + prep_t <- make_prep_student() + f_t <- brms:::posterior_predict_student(i, + prep = prep_t, output = "density", q = q_ref) + F_plus_t <- brms:::posterior_predict_student(i, + prep = prep_t, output = "probability", q = q_ref + h) + F_minus_t <- brms:::posterior_predict_student(i, + prep = prep_t, output = "probability", q = q_ref - h) + fd_t <- (F_plus_t - F_minus_t) / (2 * h) + expect_equal(f_t, fd_t, tolerance = 2e-3) +}) + +test_that("density output supports log = TRUE", { + + i <- 3 + q_ref <- 0.25 + prep_g <- make_prep_gaussian() + + dens <- brms:::posterior_predict_gaussian( + i, prep = prep_g, output = "density", q = q_ref, log = FALSE + ) + log_dens <- brms:::posterior_predict_gaussian( + i, prep = prep_g, output = "density", q = q_ref, log = TRUE + ) + + expect_equal(log_dens, log(dens), tolerance = 1e-10) +}) + +test_that("discrete families: density matches CDF increments", { + + i <- 4 + q_ref <- 3 + prep <- make_prep_count() + + check_density_increment <- function(family_fun, ...) { + dens <- family_fun(i, prep = prep, output = "density", q = q_ref, ...) + F_q <- family_fun(i, prep = prep, output = "probability", q = q_ref, ...) + F_qm1 <- family_fun(i, prep = prep, output = "probability", q = q_ref - 1, ...) + expect_equal(dens, F_q - F_qm1, tolerance = 1e-10) + } + + check_density_increment(brms:::posterior_predict_binomial) + check_density_increment(brms:::posterior_predict_beta_binomial) + check_density_increment(brms:::posterior_predict_poisson) + check_density_increment(brms:::posterior_predict_negbinomial) + check_density_increment(brms:::posterior_predict_negbinomial2) + check_density_increment(brms:::posterior_predict_zero_inflated_negbinomial) +}) + +test_that("quantile output inverts probability output (continuous)", { + + i <- 2 + p_ref <- 0.73 + + prep_g <- make_prep_gaussian() + q_g <- brms:::posterior_predict_gaussian(i, prep = prep_g, + output = "quantile", p = p_ref) + F_q_g <- brms:::posterior_predict_gaussian(i, prep = prep_g, + output = "probability", q = q_g) + expect_equal(F_q_g, rep(p_ref, length(F_q_g)), tolerance = 1e-8) + + prep_t <- make_prep_student() + q_t <- brms:::posterior_predict_student(i, prep = prep_t, + output = "quantile", p = p_ref) + F_q_t <- brms:::posterior_predict_student(i, prep = prep_t, + output = "probability", q = q_t) + expect_equal(F_q_t, rep(p_ref, length(F_q_t)), tolerance = 1e-8) +}) + +test_that("quantile output inverts CDF inequalities (discrete)", { + skip_if_density_quantile_not_available() + + i <- 5 + p_ref <- 0.81 + prep <- make_prep_count() + + check_quantile_discrete <- function(family_fun, ...) { + q <- family_fun(i, prep = prep, output = "quantile", p = p_ref, ...) + F_q <- family_fun(i, prep = prep, output = "probability", q = q, ...) + F_qm1 <- family_fun(i, prep = prep, output = "probability", q = q - 1, ...) + + expect_true(all(F_q >= p_ref)) + expect_true(all(F_qm1 < p_ref)) + } + + check_quantile_discrete(brms:::posterior_predict_binomial) + check_quantile_discrete(brms:::posterior_predict_beta_binomial) + check_quantile_discrete(brms:::posterior_predict_poisson) + check_quantile_discrete(brms:::posterior_predict_negbinomial) + check_quantile_discrete(brms:::posterior_predict_negbinomial2) + check_quantile_discrete(brms:::posterior_predict_zero_inflated_negbinomial) +}) + +test_that("quantile output supports lower.tail and log.p", { + + i <- 2 + prep_g <- make_prep_gaussian() + p_ref <- 0.2 + + q_upper <- brms:::posterior_predict_gaussian( + i, prep = prep_g, output = "quantile", + p = p_ref, lower.tail = FALSE, log.p = FALSE + ) + F_upper <- brms:::posterior_predict_gaussian( + i, prep = prep_g, output = "probability", + q = q_upper, lower.tail = FALSE, log.p = FALSE + ) + expect_equal(F_upper, rep(p_ref, length(F_upper)), tolerance = 1e-8) + + q_log <- brms:::posterior_predict_gaussian( + i, prep = prep_g, output = "quantile", + p = log(p_ref), lower.tail = TRUE, log.p = TRUE + ) + F_log <- brms:::posterior_predict_gaussian( + i, prep = prep_g, output = "probability", + q = q_log, lower.tail = TRUE, log.p = FALSE + ) + expect_equal(F_log, rep(p_ref, length(F_log)), tolerance = 1e-8) +}) + +test_that("random baseline agrees with density for selected discrete families", { + + set.seed(1234) + i <- 6 + q_ref <- 2 + prep <- make_prep_count(ns = 4000, nobs = 10) + + check_random_baseline <- function(family_fun, ...) { + draws <- family_fun(i, prep = prep, output = "random", ...) + p_emp <- mean(draws == q_ref) + p_dens <- mean(family_fun(i, prep = prep, output = "density", q = q_ref, ...)) + expect_equal(p_emp, p_dens, tolerance = 0.03) + } + + check_random_baseline(brms:::posterior_predict_binomial) + check_random_baseline(brms:::posterior_predict_poisson) + check_random_baseline(brms:::posterior_predict_negbinomial) +}) diff --git a/vignettes/brms_distribution_output_cheatsheet.Rmd b/vignettes/brms_distribution_output_cheatsheet.Rmd new file mode 100644 index 000000000..68df05ab7 --- /dev/null +++ b/vignettes/brms_distribution_output_cheatsheet.Rmd @@ -0,0 +1,395 @@ +--- +title: "Cheatsheet: Distribution outputs in posterior_predict()" +author: "brms team" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Cheatsheet: Distribution outputs in posterior_predict()} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r setup, include=FALSE} +stopifnot(require(knitr)) +knit_hooks$set(pngquant = knitr::hook_pngquant) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "ragg_png", + dpi = 96, + fig.retina = 1.5, + fig.align = "center", + out.width = "100%", + pngquant = "--speed=1 --quality=50" +) +library(ggplot2) +devtools::load_all() +if (!requireNamespace("extraDistr", quietly = TRUE)) { + stop("Package 'extraDistr' is required to evaluate this vignette.") +} +theme_set(theme_minimal(base_size = 9)) +set.seed(4026) +``` + +This cheatsheet summarizes the distribution families that currently support all +`posterior_predict()` output modes: + +- `random` +- `probability` +- `pit` +- `density` +- `quantile` + +## Supported families + +```{r support-table} +support <- data.frame( + family = c( + "gaussian", "student", "binomial", "beta_binomial", + "poisson", "negbinomial", "negbinomial2", "zero_inflated_negbinomial" + ), + distribution_backend = c( + "norm", "student_t", "binom", "beta_binomial", + "pois", "nbinom", "nbinom", "zero_inflated_negbinomial" + ), + random = "\u2713", + probability = "\u2713", + pit = "\u2713", + density = "\u2713", + quantile = "\u2713", + stringsAsFactors = FALSE +) +knitr::kable(support, align = "l") +``` + +## Mathematical details + +Let \(Y\) be the posterior predictive variable for one posterior draw \(s\), with +distribution \(F_s\) and density/mass \(f_s\). For each observation index \(i\), +`posterior_predict()` returns one value per draw \(s = 1, \dots, S\). + +### 1) `output = "random"` + +Draw +\[ +\tilde y_s \sim F_s. +\] +If truncation bounds are active (\(L, U\)), sampling is from the truncated +distribution: +\[ +F_{s,\text{tr}}(y) = \frac{F_s(y) - F_s(L)}{F_s(U) - F_s(L)}, \quad L \le y \le U. +\] + +### 2) `output = "probability"` + +For a queried value \(q\), return the (possibly truncated) CDF: +\[ +p_s(q) = F_s(q) +\] +or, with truncation, +\[ +p_s(q) = \frac{F_s(q) - F_s(L)}{F_s(U) - F_s(L)}. +\] +With `lower.tail = FALSE`, return \(1 - p_s(q)\). With `log.p = TRUE`, return +\(\log p_s(q)\). + +### 3) `output = "pit"` + +- Continuous case: PIT equals the CDF value, +\[ +\text{PIT}_s = F_s(y_i). +\] +- Discrete case: randomized PIT (to avoid spikes), +\[ +\text{PIT}_s = F_s(y_i - 1) + V_s \left[F_s(y_i) - F_s(y_i - 1)\right], \quad +V_s \sim \text{Uniform}(0,1). +\] + +### 4) `output = "density"` + +For a queried value \(q\), return +\[ +d_s(q) = f_s(q) +\] +or with truncation, +\[ +d_s(q) = \frac{f_s(q)}{F_s(U) - F_s(L)} \mathbf{1}\{L \le q \le U\}. +\] +With `log = TRUE`, return \(\log d_s(q)\). + +For discrete distributions, this corresponds to PMF values and satisfies +\[ +d_s(k) = F_s(k) - F_s(k-1). +\] + +### 5) `output = "quantile"` + +For queried probability \(p\), return +\[ +q_s(p) = F_s^{-1}(p). +\] +With truncation, the internally transformed probability is +\[ +p_s^\star = p \left[F_s(U) - F_s(L)\right] + F_s(L), +\] +and then +\[ +q_s(p) = F_s^{-1}(p_s^\star). +\] +`lower.tail` and `log.p` are first converted to standard probabilities before +applying these formulas. + +### Zero-inflated and hurdle families + +For zero-inflated families (parameter \(\pi\), baseline distribution \(G\)): +\[ +P(Y=0) = \pi + (1-\pi)G(0), \qquad +P(Y=y>0) = (1-\pi)G(y). +\] + +For hurdle families (parameter \(h\), baseline distribution \(G\)): +\[ +P(Y=0) = h, \qquad +P(Y=y>0) = (1-h)\frac{G(y)}{1-G(0)}. +\] + +These definitions induce the corresponding CDF, density/mass, and quantile +computations used by `probability`, `density`, and `quantile`. + +```{r data-helpers, include=FALSE} +specs <- list( + list( + family = "gaussian", type = "continuous", x = seq(-4, 4, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dnorm(x, mean = 0, sd = 1), + cdf = function(q) pnorm(q, mean = 0, sd = 1), + qf = function(p) qnorm(p, mean = 0, sd = 1), + r = function(n) rnorm(n, mean = 0, sd = 1) + ), + list( + family = "student", type = "continuous", x = seq(-6, 6, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dstudent_t(x, df = 7, mu = 0, sigma = 1), + cdf = function(q) pstudent_t(q, df = 7, mu = 0, sigma = 1), + qf = function(p) qstudent_t(p, df = 7, mu = 0, sigma = 1), + r = function(n) rstudent_t(n, df = 7, mu = 0, sigma = 1) + ), + list( + family = "binomial", type = "discrete", x = 0:20, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dbinom(x, size = 20, prob = 0.4), + cdf = function(q) pbinom(q, size = 20, prob = 0.4), + qf = function(p) qbinom(p, size = 20, prob = 0.4), + r = function(n) rbinom(n, size = 20, prob = 0.4) + ), + list( + family = "beta_binomial", type = "discrete", x = 0:20, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dbeta_binomial(x, size = 20, mu = 0.4, phi = 8), + cdf = function(q) pbeta_binomial(q, size = 20, mu = 0.4, phi = 8), + qf = function(p) qbeta_binomial(p, size = 20, mu = 0.4, phi = 8), + r = function(n) rbeta_binomial(n, size = 20, mu = 0.4, phi = 8) + ), + list( + family = "poisson", type = "discrete", x = 0:18, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dpois(x, lambda = 5), + cdf = function(q) ppois(q, lambda = 5), + qf = function(p) qpois(p, lambda = 5), + r = function(n) rpois(n, lambda = 5) + ), + list( + family = "negbinomial", type = "discrete", x = 0:24, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dnbinom(x, mu = 5, size = 2), + cdf = function(q) pnbinom(q, mu = 5, size = 2), + qf = function(p) qnbinom(p, mu = 5, size = 2), + r = function(n) rnbinom(n, mu = 5, size = 2) + ), + list( + family = "negbinomial2", type = "discrete", x = 0:24, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dnbinom(x, mu = 5, size = 1 / 0.6), + cdf = function(q) pnbinom(q, mu = 5, size = 1 / 0.6), + qf = function(p) qnbinom(p, mu = 5, size = 1 / 0.6), + r = function(n) rnbinom(n, mu = 5, size = 1 / 0.6) + ), + list( + family = "zero_inflated_negbinomial", type = "discrete", x = 0:24, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dzero_inflated_negbinomial(x, mu = 5, shape = 2, zi = 0.25), + cdf = function(q) pzero_inflated_negbinomial(q, mu = 5, shape = 2, zi = 0.25), + qf = function(p) qzero_inflated_negbinomial(p, mu = 5, shape = 2, zi = 0.25), + r = function(n) { + base <- rnbinom(n, mu = 5, size = 2) + is_zi <- runif(n) < 0.25 + base[is_zi] <- 0 + base + } + ) +) + +make_output_data <- function(spec) { + density_df <- data.frame( + family = spec$family, + type = spec$type, + x = spec$x, + y = spec$d(spec$x) + ) + probability_df <- data.frame( + family = spec$family, + type = spec$type, + x = spec$x, + y = spec$cdf(spec$x) + ) + quantile_df <- data.frame( + family = spec$family, + type = spec$type, + x = spec$p, + y = spec$qf(spec$p) + ) + + draws <- spec$r(500) + ecdf_fun <- ecdf(draws) + random_df <- data.frame( + family = spec$family, + type = spec$type, + x = spec$x, + y = ecdf_fun(spec$x) + ) + + pit_draws <- spec$r(400) + if (identical(spec$type, "continuous")) { + pit <- spec$cdf(pit_draws) + } else { + u <- runif(length(pit_draws)) + pit <- spec$cdf(pit_draws - 1) + u * (spec$cdf(pit_draws) - spec$cdf(pit_draws - 1)) + } + pit <- pmax(0, pmin(1, pit)) + pit_hist <- hist(pit, breaks = seq(0, 1, by = 0.1), plot = FALSE) + pit_df <- data.frame( + family = spec$family, + midpoint = pit_hist$mids, + density = pit_hist$density + ) + + list( + density = density_df, + probability = probability_df, + quantile = quantile_df, + random = random_df, + pit = pit_df + ) +} + +all_data <- lapply(specs, make_output_data) +density_data <- do.call(rbind, lapply(all_data, `[[`, "density")) +probability_data <- do.call(rbind, lapply(all_data, `[[`, "probability")) +quantile_data <- do.call(rbind, lapply(all_data, `[[`, "quantile")) +random_data <- do.call(rbind, lapply(all_data, `[[`, "random")) +pit_data <- do.call(rbind, lapply(all_data, `[[`, "pit")) + +panel_theme <- theme( + strip.text = element_text(size = 8), + axis.title = element_blank(), + panel.grid.minor = element_blank() +) +``` + +## Random output + +Empirical CDF of random draws (`output = "random"`). + +```{r random-plot, fig.width=9, fig.height=4.2} +ggplot(random_data, aes(x = x, y = y)) + + geom_line(linewidth = 0.4, color = "#2c7fb8") + + facet_wrap(~ family, scales = "free_x", ncol = 4) + + labs(title = "Random output (empirical CDF thumbnails)", y = "ECDF") + + panel_theme +``` + +## Probability output + +CDF values (`output = "probability"`). + +```{r probability-plot, fig.width=9, fig.height=4.2} +ggplot(probability_data, aes(x = x, y = y)) + + geom_line( + data = subset(probability_data, type == "continuous"), + linewidth = 0.4, color = "#1b9e77" + ) + + geom_step( + data = subset(probability_data, type == "discrete"), + linewidth = 0.4, color = "#1b9e77" + ) + + facet_wrap(~ family, scales = "free_x", ncol = 4) + + labs(title = "Probability output (CDF thumbnails)", y = "P(X <= x)") + + panel_theme +``` + +## PIT output + +PIT histogram (`output = "pit"`). For calibrated models, these are near-uniform. + +```{r pit-plot, fig.width=9, fig.height=4.2} +ggplot(pit_data, aes(x = midpoint, y = density)) + + geom_col(width = 0.085, fill = "#7570b3", alpha = 0.75) + + geom_hline(yintercept = 1, linewidth = 0.25, linetype = "dashed") + + facet_wrap(~ family, ncol = 4) + + scale_x_continuous(limits = c(0, 1), breaks = c(0, 0.5, 1)) + + labs(title = "PIT output (thumbnail histograms)", y = "Density") + + panel_theme +``` + +## Density output + +PDF/PMF values (`output = "density"`). + +```{r density-plot, fig.width=9, fig.height=4.2} +ggplot() + + geom_line( + data = subset(density_data, type == "continuous"), + aes(x = x, y = y), + linewidth = 0.45, color = "#d95f02" + ) + + geom_col( + data = subset(density_data, type == "discrete"), + aes(x = x, y = y), + width = 0.85, fill = "#d95f02", alpha = 0.7 + ) + + facet_wrap(~ family, scales = "free_x", ncol = 4) + + labs(title = "Density output (PDF/PMF thumbnails)", y = "Density / Mass") + + panel_theme +``` + +## Quantile output + +Inverse CDF values (`output = "quantile"`). + +```{r quantile-plot, fig.width=9, fig.height=4.2} +ggplot(quantile_data, aes(x = x, y = y)) + + geom_line( + data = subset(quantile_data, type == "continuous"), + linewidth = 0.4, color = "#e7298a" + ) + + geom_step( + data = subset(quantile_data, type == "discrete"), + linewidth = 0.4, color = "#e7298a" + ) + + facet_wrap(~ family, scales = "free_y", ncol = 4) + + labs(title = "Quantile output (inverse-CDF thumbnails)", x = "p", y = "Q(p)") + + panel_theme +``` + +## Notes + +- Continuous families have `probability == pit`. +- Discrete families use randomized PIT to avoid spikes. +- The parameter values here are illustrative; the output shape changes with + posterior draws in real model fits. From 9b9f986dffbc632077cdd86e0eacf473e9785c85 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Tue, 28 Apr 2026 09:00:01 +0300 Subject: [PATCH 40/63] feat: add outcome support for additional families --- R/distributions.R | 66 ++- R/posterior_predict.R | 184 +++++--- tests/testthat/tests.distributions.R | 11 + tests/testthat/tests.posterior_predict.R | 418 +++++++++--------- ...tests.posterior_predict_density_quantile.R | 215 --------- 5 files changed, 389 insertions(+), 505 deletions(-) delete mode 100644 tests/testthat/tests.posterior_predict_density_quantile.R diff --git a/R/distributions.R b/R/distributions.R index 220d3c4e6..4bcca4b4c 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -1809,6 +1809,14 @@ pzero_inflated_poisson <- function(q, lambda, zi, lower.tail = TRUE, .pzero_inflated(q, "pois", zi, pars, lower.tail, log.p) } +#' @rdname ZeroInflated +#' @export +qzero_inflated_poisson <- function(p, lambda, zi, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(lambda) + .qzero_inflated(p, "pois", zi, pars, lower.tail, log.p) +} + #' @rdname ZeroInflated #' @export dzero_inflated_negbinomial <- function(x, mu, shape, zi, log = FALSE) { @@ -1828,14 +1836,8 @@ pzero_inflated_negbinomial <- function(q, mu, shape, zi, lower.tail = TRUE, #' @export qzero_inflated_negbinomial <- function(p, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) { - p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) - args <- do_call(expand, nlist(p, mu, shape, zi)) - p_nb <- with(args, ifelse(zi == 1, 0, (p - zi) / (1 - zi))) - p_nb <- pmin(1, pmax(0, p_nb)) - out <- qnbinom(p_nb, mu = args$mu, size = args$shape) - out[!is.finite(args$p)] <- args$p[!is.finite(args$p)] - dim(out) <- attributes(args)$max_dim - out + pars <- nlist(mu, size = shape) + .qzero_inflated(p, "nbinom", zi, pars, lower.tail, log.p) } #' @rdname ZeroInflated @@ -1853,6 +1855,14 @@ pzero_inflated_binomial <- function(q, size, prob, zi, lower.tail = TRUE, .pzero_inflated(q, "binom", zi, pars, lower.tail, log.p) } +#' @rdname ZeroInflated +#' @export +qzero_inflated_binomial <- function(p, size, prob, zi, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(size, prob) + .qzero_inflated(p, "binom", zi, pars, lower.tail, log.p) +} + #' @rdname ZeroInflated #' @export dzero_inflated_beta_binomial <- function(x, size, mu, phi, zi, log = FALSE) { @@ -1868,6 +1878,14 @@ pzero_inflated_beta_binomial <- function(q, size, mu, phi, zi, .pzero_inflated(q, "beta_binomial", zi, pars, lower.tail, log.p) } +#' @rdname ZeroInflated +#' @export +qzero_inflated_beta_binomial <- function(p, size, mu, phi, zi, + lower.tail = TRUE, log.p = FALSE) { + pars <- nlist(size, mu, phi) + .qzero_inflated(p, "beta_binomial", zi, pars, lower.tail, log.p) +} + #' @rdname ZeroInflated #' @export dzero_inflated_beta <- function(x, shape1, shape2, zi, log = FALSE) { @@ -1885,6 +1903,15 @@ pzero_inflated_beta <- function(q, shape1, shape2, zi, lower.tail = TRUE, .phurdle(q, "beta", zi, pars, lower.tail, log.p, type = "real") } +#' @rdname ZeroInflated +#' @export +qzero_inflated_beta <- function(p, shape1, shape2, zi, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(shape1, shape2) + # zi_beta is technically a hurdle model + .qzero_inflated(p, "beta", zi, pars, lower.tail, log.p) +} + # @rdname ZeroInflated # @export dzero_inflated_asym_laplace <- function(x, mu, sigma, quantile, zi, @@ -1965,6 +1992,29 @@ pzero_inflated_asym_laplace <- function(q, mu, sigma, quantile, zi, out } +# quantile function of a zero-inflated distribution +# @param dist name of the distribution +# @param zi bernoulli zero-inflated parameter +# @param pars list of parameters passed to qfun +.qzero_inflated <- function(p, dist, zi, pars, lower.tail, log.p) { + stopifnot(is.list(pars)) + dist <- as_one_character(dist) + lower.tail <- as_one_logical(lower.tail) + log.p <- as_one_logical(log.p) + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- expand(dots = c(nlist(p, zi), pars)) + p <- args$p + zi <- args$zi + pars <- args[names(pars)] + qfun <- paste0("q", dist) + p_dist <- ifelse(zi == 1, 0, (p - zi) / (1 - zi)) + p_dist <- pmin(1, pmax(0, p_dist)) + out <- do_call(qfun, c(list(p_dist), pars)) + out[!is.finite(p)] <- p[!is.finite(p)] + dim(out) <- attributes(args)$max_dim + out +} + #' Hurdle Distributions #' #' Density and distribution functions for hurdle distributions. diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 62f3aa4c2..27bce8eab 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -330,7 +330,8 @@ validate_pp_method <- function(method) { # @param ... ignored arguments # @param A vector of length prep$ndraws containing draws # from the posterior predictive distribution -posterior_predict_gaussian <- function(i, prep, output = "random", ntrys = 5, ...) { +posterior_predict_gaussian <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) @@ -341,7 +342,8 @@ posterior_predict_gaussian <- function(i, prep, output = "random", ntrys = 5, .. ) } -posterior_predict_student <- function(i, prep, output = "random", ntrys = 5, ...) { +posterior_predict_student <- function(i, prep, output = "random", + ntrys = 5, ...) { nu <- get_dpar(prep, "nu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) @@ -353,13 +355,14 @@ posterior_predict_student <- function(i, prep, output = "random", ntrys = 5, ... ) } -posterior_predict_lognormal <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "lnorm", - meanlog = get_dpar(prep, "mu", i = i), - sdlog = get_dpar(prep, "sigma", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_lognormal <- function(i, prep, output = "random", + ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "lnorm", meanlog = mu, sdlog = sigma, ... ) } @@ -502,7 +505,8 @@ posterior_predict_student_fcor <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_binomial <- function(i, prep, output = "random", ntrys = 5, ...) { +posterior_predict_binomial <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) size <- prep$data$trials[i] @@ -513,7 +517,7 @@ posterior_predict_binomial <- function(i, prep, output = "random", ntrys = 5, .. } posterior_predict_beta_binomial <- function(i, prep, output = "random", - ntrys = 5, ...) { + ntrys = 5, ...) { size <- prep$data$trials[i] mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) @@ -524,12 +528,18 @@ posterior_predict_beta_binomial <- function(i, prep, output = "random", ) } -posterior_predict_bernoulli <- function(i, prep, ...) { +posterior_predict_bernoulli <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) - rbinom(length(mu), size = 1, prob = mu) + + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "binom", prob = mu, size = 1, ... + ) } -posterior_predict_poisson <- function(i, prep, output = "random", ntrys = 5, ...) { +posterior_predict_poisson <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) @@ -540,7 +550,7 @@ posterior_predict_poisson <- function(i, prep, output = "random", ntrys = 5, ... } posterior_predict_negbinomial <- function(i, prep, output = "random", - ntrys = 5, ...) { + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- get_dpar(prep, "shape", i) @@ -553,7 +563,7 @@ posterior_predict_negbinomial <- function(i, prep, output = "random", } posterior_predict_negbinomial2 <- function(i, prep, output = "random", - ntrys = 5, ...) { + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) sigma <- get_dpar(prep, "sigma", i) @@ -607,25 +617,25 @@ posterior_predict_exponential <- function(i, prep, ntrys = 5, ...) { ) } -posterior_predict_gamma <- function(i, prep, ntrys = 5, ...) { +posterior_predict_gamma <- function(i, prep, output = "random", + ntrys = 5, ...) { shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / shape - rcontinuous( - n = prep$ndraws, dist = "gamma", - shape = shape, scale = scale, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "gamma", shape = shape, scale = scale, ... ) } -posterior_predict_weibull <- function(i, prep, ntrys = 5, ...) { +posterior_predict_weibull <- function(i, prep, output = "random", + ntrys = 5, ...) { shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / gamma(1 + 1 / shape) - rcontinuous( - n = prep$ndraws, dist = "weibull", - shape = shape, scale = scale, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "weibull", shape = shape, scale = scale, ... ) } @@ -691,14 +701,13 @@ posterior_predict_wiener <- function(i, prep, negative_rt = FALSE, ntrys = 5, out } -posterior_predict_beta <- function(i, prep, ntrys = 5, ...) { +posterior_predict_beta <- function(i, prep, output = "random", ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) - rcontinuous( - n = prep$ndraws, dist = "beta", - shape1 = mu * phi, shape2 = (1 - mu) * phi, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "beta", shape1 = mu * phi, shape2 = (1 - mu) * phi, ... ) } @@ -823,15 +832,28 @@ posterior_predict_hurdle_cumulative <- function(i, prep, ...) { ) } -posterior_predict_zero_inflated_beta <- function(i, prep, ...) { +posterior_predict_zero_inflated_beta <- function(i, prep, output = "random", + ntrys = 5, ...) { zi <- get_dpar(prep, "zi", i = i) mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) - tmp <- runif(prep$ndraws, 0, 1) - ifelse( - tmp < zi, 0, - rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) - ) + shape1 <- mu * phi + shape2 <- (1 - mu) * phi + + if (output == "random") { + out <- predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "beta", shape1 = shape1, shape2 = shape2, ... + ) + tmp <- runif(prep$ndraws, 0, 1) + out <- ifelse(tmp < zi, 0, out) + } else { + out <- predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "zero_inflated_beta", shape1 = shape1, shape2 = shape2, zi = zi, ... + ) + } + out } posterior_predict_zero_one_inflated_beta <- function(i, prep, ...) { @@ -847,18 +869,31 @@ posterior_predict_zero_one_inflated_beta <- function(i, prep, ...) { ) } -posterior_predict_zero_inflated_poisson <- function(i, prep, ...) { +posterior_predict_zero_inflated_poisson <- function(i, prep, output = "random", + ntrys = 5, ...) { # zi is the bernoulli zero-inflation parameter zi <- get_dpar(prep, "zi", i = i) lambda <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - # compare with zi to incorporate the zero-inflation process - tmp <- runif(ndraws, 0, 1) - ifelse(tmp < zi, 0L, rpois(ndraws, lambda = lambda)) + lambda <- multiply_dpar_rate_denom(lambda, prep, i = i) + + if (output == "random") { + out <- predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "pois", lambda = lambda, ... + ) + tmp <- runif(prep$ndraws, 0, 1) + out <- ifelse(tmp < zi, 0L, out) + } else { + out <- predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "zero_inflated_poisson", lambda = lambda, zi = zi, ... + ) + } + out } posterior_predict_zero_inflated_negbinomial <- function(i, prep, - output = "random", ...) { + output = "random", ...) { zi <- get_dpar(prep, "zi", i = i) mu <- get_dpar(prep, "mu", i = i) shape <- get_dpar(prep, "shape", i = i) @@ -875,25 +910,51 @@ posterior_predict_zero_inflated_negbinomial <- function(i, prep, out } -posterior_predict_zero_inflated_binomial <- function(i, prep, ...) { +posterior_predict_zero_inflated_binomial <- function(i, prep, output = "random", + ntrys = 5, ...) { zi <- get_dpar(prep, "zi", i = i) trials <- prep$data$trials[i] prob <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - tmp <- runif(ndraws, 0, 1) - ifelse(tmp < zi, 0L, rbinom(ndraws, size = trials, prob = prob)) + + if (output == "random") { + out <- predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "binom", size = trials, prob = prob, ... + ) + tmp <- runif(prep$ndraws, 0, 1) + out <- ifelse(tmp < zi, 0L, out) + } else { + out <- predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "zero_inflated_binomial", size = trials, prob = prob, zi = zi, ... + ) + } + out } -posterior_predict_zero_inflated_beta_binomial <- function(i, prep, ...) { +posterior_predict_zero_inflated_beta_binomial <- function(i, prep, + output = "random", + ntrys = 5, ...) { zi <- get_dpar(prep, "zi", i = i) trials <- prep$data$trials[i] mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) - ndraws <- prep$ndraws - draws <- rbeta_binomial(ndraws, size = trials, mu = mu, phi = phi) - tmp <- runif(ndraws, 0, 1) - draws[tmp < zi] <- 0L - draws + + if (output == "random") { + out <- predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "beta_binomial", size = trials, mu = mu, phi = phi, ... + ) + tmp <- runif(prep$ndraws, 0, 1) + out <- ifelse(tmp < zi, 0L, out) + } else { + out <- predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "zero_inflated_beta_binomial", + size = trials, mu = mu, phi = phi, zi = zi, ... + ) + } + out } posterior_predict_categorical <- function(i, prep, ...) { @@ -1174,9 +1235,8 @@ predict_continuous_helper <- function( # @param p optional custom probability value for quantile output # @param ... additional arguments passed to the distribution functions # @return a vector of draws -predict_discrete_helper <- function( - i, prep, output, distribution, ntrys = NULL, q = NULL, p = NULL, ... -) { +predict_discrete_helper <- function(i, prep, output, distribution, ntrys = NULL, + q = NULL, p = NULL, ...) { lb <- prep$data$lb[i] ub <- prep$data$ub[i] if (output %in% c("probability", "pit", "density") && is.null(q)) q <- prep$data$Y[i] @@ -1189,7 +1249,7 @@ predict_discrete_helper <- function( dots <- list(...) dots[c("log.p", "lower.tail", "log", "p")] <- NULL do.call(rdiscrete, c(list(n = prep$ndraws, distribution = distribution, - lb = lb, ub = ub, ntrys = ntrys), dots)) + lb = lb, ub = ub, ntrys = ntrys), dots)) }, "probability" = { compute_cdf(q = q, distribution = distribution, lb = lb, ub = ub, @@ -1222,7 +1282,7 @@ predict_discrete_helper <- function( # @return a vector of probability values # @noRd compute_cdf <- function(q, distribution, lb, ub, randomized, lower.tail = TRUE, - log.p = FALSE, ...) { + log.p = FALSE, ...) { args <- validate_distribution_args(distribution, fun_prefix = "p", ...) pdist <- paste0("p", distribution) # prepare computation of (non-)truncated cdf @@ -1298,7 +1358,7 @@ compute_density <- function(q, distribution, lb, ub, log = FALSE, ...) { # @return a vector of quantile values # @noRd compute_quantile <- function(p, distribution, lb, ub, lower.tail = TRUE, - log.p = FALSE, ...) { + log.p = FALSE, ...) { qargs <- validate_distribution_args(distribution, fun_prefix = "q", ...) pargs <- validate_distribution_args(distribution, fun_prefix = "p", ...) qdist <- paste0("q", distribution) diff --git a/tests/testthat/tests.distributions.R b/tests/testthat/tests.distributions.R index a59063186..3e0d6e13f 100644 --- a/tests/testthat/tests.distributions.R +++ b/tests/testthat/tests.distributions.R @@ -158,32 +158,43 @@ test_that("zero-inflated distribution functions run without errors", { skip_if_not_installed("extraDistr") n <- 10 x <- rpois(n, lambda = 1) + p <- rbeta(n, shape1 = 2, shape2 = 2) res <- dzero_inflated_poisson(x, lambda = 1, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_poisson(x, lambda = 1, zi = 0.1) expect_true(length(res) == n) + res <- qzero_inflated_poisson(p, lambda = 1, zi = 0.1) + expect_true(length(res) == n) res <- dzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) expect_true(length(res) == n) + res <- qzero_inflated_negbinomial(p, mu = 2, shape = 5, zi = 0.1) + expect_true(length(res) == n) res <- dzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) expect_true(length(res) == n) + res <- qzero_inflated_binomial(p, size = c(2, 10), prob = 0.4, zi = 0.1) + expect_true(length(res) == n) res <- dzero_inflated_beta_binomial(x, c(2, 10), mu = 0.4, phi = 1, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_beta_binomial(x, c(2, 10), mu = 0.4, phi = 1, zi = 0.1) expect_true(length(res) == n) + res <- qzero_inflated_beta_binomial(p, c(2, 10), mu = 0.4, phi = 1, zi = 0.1) + expect_true(length(res) == n) x <- c(rbeta(n - 2, shape1 = 2, shape2 = 3), 0, 0) res <- dzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) expect_true(length(res) == n) + res <- qzero_inflated_beta(p, shape1 = 2, shape2 = 3, zi = 0.1) + expect_true(length(res) == n) }) test_that("hurdle distribution functions run without errors", { diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index b0094d176..069101491 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -440,201 +440,212 @@ test_that("posterior_predict_custom runs without errors", { expect_equal(length(brms:::posterior_predict_custom(sample(1:nobs, 1), prep)), ns) }) -test_that("posterior_predict_gaussian runs with various 'output' values without error", { - fit <- rename_pars(brms:::brmsfit_example3) - prep <- brms::prepare_predictions(fit) - model_fit <- fit$fit@sim - S <- model_fit$chains * (model_fit$iter - model_fit$warmup) - i <- 1 - - # random draws from Gaussian - rpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") - expect_equal(length(rpred), S) - - # compute PIT values (q = prep$data$Y[i]) - PITs <- brms:::posterior_predict_gaussian(i, prep = prep, output = "probability") - expect_equal(length(PITs), S) - expect_true(all(PITs >= 0 & PITs <= 1)) - - # compute cdf based on custom 'q' - qpred <- brms:::posterior_predict_gaussian(i, q = 15, prep = prep, output = "probability") - expect_equal(length(qpred), S) - expect_false(all(PITs == qpred)) - expect_true(all(qpred >= 0 & qpred <= 1)) -}) - -test_that("truncated posterior_predict_gaussian runs with various 'output' values without error", { - set.seed(1335) - ns <- 30 - nobs <- 15 - i <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rchisq(ns, 3) - ) - prep$data <- list( - Y = rnorm(nobs), - lb = replicate(nobs, 0), - ub = replicate(nobs, 10) - ) - - mu <- brms:::get_dpar(prep, "mu", i = i) - sigma <- brms:::get_dpar(prep, "sigma", i = i) - sigma <- brms:::add_sigma_se(sigma, prep, i = i) - # expected cdf of truncated normal - ptruncnorm <- function(q, a, b, mean, sd) { - (pnorm(q, mean, sd) - pnorm(a, mean, sd)) / - (pnorm(b, mean, sd) - pnorm(a, mean, sd)) - } - # compute cdf for truncated distribution - obs_trunc_PITs <- brms:::posterior_predict_gaussian(i, prep = prep, - output = "probability") - expected_PITs <- ptruncnorm(q = prep$data$Y[i], a = prep$data$lb[i], - b = prep$data$ub[i], mean = mu, sd = sigma) - expect_equal(obs_trunc_PITs, expected_PITs) - - # take random draws from a truncated distribution - rpred <- brms:::posterior_predict_gaussian(i, prep = prep, output = "random") - expect_true(all(rpred >= prep$data$lb[i] & rpred <= prep$data$ub[i])) -}) - -test_that("posterior_predict_student runs with various 'output' values without error", { - set.seed(1334) - ns <- 30 - nobs <- 10 +make_prep_outcome <- function( + ns = 120, nobs = 8, seed = 1001, dpars = list(), data = list()) { + set.seed(seed) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rchisq(ns, 3), - nu = rgamma(ns, 4) - ) - prep$data <- list(Y = rstudent_t(nobs, df = 3)) - i <- 8 - - # random draws from non-truncated t - rpred <- brms:::posterior_predict_student(i, prep = prep, output = "random") - expect_equal(length(rpred), ns) - - # compute PIT values (q = prep$data$Y[i]) - PITs <- brms:::posterior_predict_student(i, prep = prep, output = "probability") - expect_equal(length(PITs), ns) - expect_true(all(PITs >= 0 & PITs <= 1)) - - # compute cdf based on custom 'q' - qpred <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") - expect_equal(length(qpred), ns) - expect_false(all(PITs == qpred)) - expect_true(all(qpred >= 0 & qpred <= 1)) - - prep$data$lb <- replicate(nobs, 0) - prep$data$ub <- replicate(nobs, 30) - - # random draws from truncated t - rpred <- brms:::posterior_predict_student(i, prep = prep, output = "random") - expect_true(all(rpred >= prep$data$lb[i] & rpred <= prep$data$ub[i])) - - # compute PIT values for truncated t (q = prep$data$Y[i]) - PITs_trunc <- brms:::posterior_predict_student(i, prep = prep, output = "probability") - expect_equal(length(PITs_trunc), ns) - expect_false(all(PITs == PITs_trunc)) - - # compute cdf for truncated t based on custom 'q' - qpred_trunc <- brms:::posterior_predict_student(i, q = 15, prep = prep, output = "probability") - expect_equal(length(qpred_trunc), ns) - expect_false(all(qpred == qpred_trunc)) -}) - -test_that("posterior_predict of binomial variants works for different -'output' values without error", { - ns <- 25 - nobs <- 10 + prep$dpars <- dpars + prep$data <- modifyList( + list(Y = rnorm(nobs), lb = rep(NULL, nobs), ub = rep(NULL, nobs)), + data + ) + prep +} + +make_prep_gaussian_outcome <- function(ns = 120, nobs = 8) { + make_prep_outcome( + ns = ns, nobs = nobs, seed = 1001, + dpars = list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rgamma(ns, shape = 4, rate = 3) + ) + ) +} + +make_prep_student_outcome <- function(ns = 120, nobs = 8) { + make_prep_outcome( + ns = ns, nobs = nobs, seed = 1002, + dpars = list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rgamma(ns, shape = 4, rate = 3), + nu = rgamma(ns, shape = 6, rate = 1) + 2 + ) + ) +} + +make_prep_positive_outcome <- function(ns = 120, nobs = 8) { + make_prep_outcome( + ns = ns, nobs = nobs, seed = 1003, + dpars = list( + mu = matrix(exp(rnorm(ns * nobs, mean = 0.2, sd = 0.4)), ncol = nobs), + sigma = rgamma(ns, shape = 4, rate = 3), + shape = rgamma(ns, shape = 6, rate = 2) + 0.5 + ), + data = list(Y = rgamma(nobs, shape = 2, rate = 1)) + ) +} + +make_prep_beta_outcome <- function(ns = 140, nobs = 9) { + make_prep_outcome( + ns = ns, nobs = nobs, seed = 1004, + dpars = list( + mu = matrix(plogis(rnorm(ns * nobs)), ncol = nobs), + phi = rgamma(ns, shape = 5, rate = 1), + zi = rbeta(ns, 1.5, 5), + zoi = rbeta(ns, 1.5, 5), + coi = rbeta(ns, 2, 6) + ), + data = list(Y = rbeta(nobs, shape1 = 2, shape2 = 3)) + ) +} + +make_prep_outcome_discrete <- function(ns = 160, nobs = 12, seed = 1005) { + set.seed(seed) trials <- sample(10:30, nobs, replace = TRUE) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( - eta = matrix(rnorm(ns * nobs), ncol = nobs), - shape = rgamma(ns, 4), xi = 0, phi = rgamma(ns, 1) + mu = matrix(plogis(rnorm(ns * nobs)), ncol = nobs), + phi = rgamma(ns, shape = 5, rate = 1), + shape = rgamma(ns, shape = 4, rate = 1), + sigma = rgamma(ns, shape = 3, rate = 2), + zi = rbeta(ns, 1.5, 5) ) - prep$dpars$nu <- prep$dpars$sigma <- prep$dpars$shape + 1 - i <- 3 - - prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) - prep$data <- list( - trialsb = trials, - Y = rbinom(nobs, size = trials, prob = prep$dpars$mu) + Y = rpois(nobs, lambda = 5), + trials = trials, + lb = rep(NULL, nobs), + ub = rep(NULL, nobs) ) + prep +} - PITs <- brms:::posterior_predict_binomial(i, prep = prep, output = "pit") - expect_equal(length(PITs), ns) - expect_true(all(PITs >= 0 & PITs <= 1)) +expect_outcome_random <- function(family_fun, prep, i, support = c(-Inf, Inf), + check_integer = FALSE, seed = 1234) { + set.seed(seed) + random_outcome <- family_fun(i, prep = prep) - qpred <- brms:::posterior_predict_binomial(i, q = 5, prep = prep, output = "pit") - expect_equal(length(qpred), ns) - expect_true(all(qpred >= 0 & qpred <= 1)) - expect_false(all(PITs == qpred)) + testthat::expect_length(random_outcome, prep$ndraws) + testthat::expect_true(all(is.finite(random_outcome))) - probs <- brms:::posterior_predict_beta_binomial(i, prep = prep, - output = "probability") - expect_equal(length(probs), ns) + if (is.finite(support[1])) { + testthat::expect_true(all(random_outcome >= support[1])) + } + if (is.finite(support[2])) { + testthat::expect_true(all(random_outcome <= support[2])) + } + if (isTRUE(check_integer)) { + testthat::expect_true(all(abs(random_outcome - round(random_outcome)) < 1e-8)) + } +} - PITs <- brms:::posterior_predict_beta_binomial(i, prep = prep, output = "pit") - expect_equal(length(PITs), ns) +expect_outcome_modes <- function(family_fun, prep, i, q_ref, p_ref, + support = c(-Inf, Inf), + check_integer = FALSE) { + expect_outcome_random( + family_fun = family_fun, prep = prep, i = i, support = support, + check_integer = check_integer + ) - prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta)*30 - probs <- brms:::posterior_predict_negbinomial(i, prep = prep, output = "pit") - expect_equal(length(probs), ns) + prob <- family_fun(i, prep = prep, output = "probability", q = q_ref) + pit <- family_fun(i, prep = prep, output = "pit", q = q_ref) + dens <- family_fun(i, prep = prep, output = "density", q = q_ref) + q <- family_fun(i, prep = prep, output = "quantile", p = p_ref) - PITs <- brms:::posterior_predict_negbinomial(i, prep = prep, - output = "probability") - expect_equal(length(PITs), ns) + for (x in list(prob, pit, dens, q)) { + testthat::expect_type(x, "double") + testthat::expect_length(x, prep$ndraws) + testthat::expect_true(all(is.finite(x) | is.na(x))) + } +} - prep$dpars$sigma <- 1/prep$dpars$shape - probs <- brms:::posterior_predict_negbinomial2(i, prep = prep, output = "pit") - expect_equal(length(probs), ns) +test_that("posterior_predict outcome argument works for continuous families", { + i <- 3 - PITs <- brms:::posterior_predict_negbinomial2(i, prep = prep, - output = "probability") - expect_equal(length(PITs), ns) + family_specs <- list( + gaussian = list( + fun = brms:::posterior_predict_gaussian, q_ref = 0.25, p_ref = 0.73, + support = c(-Inf, Inf), prep = make_prep_gaussian_outcome() + ), + student = list( + fun = brms:::posterior_predict_student, q_ref = 0.25, p_ref = 0.73, + support = c(-Inf, Inf), prep = make_prep_student_outcome() + ), + lognormal = list( + fun = brms:::posterior_predict_lognormal, q_ref = 1.2, p_ref = 0.73, + support = c(0, Inf), prep = make_prep_positive_outcome() + ), + gamma = list( + fun = brms:::posterior_predict_gamma, q_ref = 1.2, p_ref = 0.73, + support = c(0, Inf), prep = make_prep_positive_outcome() + ), + weibull = list( + fun = brms:::posterior_predict_weibull, q_ref = 1.2, p_ref = 0.73, + support = c(0, Inf), prep = make_prep_positive_outcome() + ), + beta = list( + fun = brms:::posterior_predict_beta, q_ref = 0.4, p_ref = 0.73, + support = c(0, 1), prep = make_prep_beta_outcome() + ), + zero_inflated_beta = list( + fun = brms:::posterior_predict_zero_inflated_beta, q_ref = 0.4, p_ref = 0.8, + support = c(0, 1), prep = make_prep_beta_outcome() + ), + zero_one_inflated_beta = list( + fun = brms:::posterior_predict_zero_one_inflated_beta, q_ref = 0.4, p_ref = 0.8, + support = c(0, 1), prep = make_prep_beta_outcome() + ) + ) + + for (spec in family_specs) { + expect_outcome_modes( + family_fun = spec$fun, + prep = spec$prep, + i = i, + q_ref = spec$q_ref, + p_ref = spec$p_ref, + support = spec$support + ) + } }) -test_that("posterior_predict_poisson works for different 'output' values without error", { - set.seed(1386) - ns <- 25 - nobs <- 10 - trials <- sample(10:30, nobs, replace = TRUE) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = exp(matrix(rnorm(ns * nobs), ncol = nobs)) - ) - prep$data <- list( - Y = rpois(nobs, lambda = prep$dpars$mu) - ) +test_that("posterior_predict outcome argument works for discrete families", { i <- 4 - - pred <- brms:::posterior_predict_poisson(i, prep = prep, output = "random") - expect_equal(length(pred), ns) - - PITs <- posterior_predict_poisson(i, prep = prep, output = "pit") - expect_equal(length(PITs), ns) - expect_true(all(PITs >= 0 & PITs <= 1)) - - # truncation interval [1, 6] - prep$data$lb <- replicate(nobs, 1) - prep$data$ub <- replicate(nobs, 6) - - rpred_trunc <- posterior_predict_poisson(i, prep = prep, output = "random", ntrys = 1000) - # check whether invalid draws were returned - # in case of invalid draws, the corresponding draw is a double and not an integer - # this implementation is not ideal when posterior_predict is used by developers outside brms - # would be better to return NA for invalid draws, or to throw an error if ntrys is exceeded or so - rpred_trunc <- brms:::check_discrete_trunc_bounds(rpred_trunc, prep$data$lb[i], prep$data$ub[i]) - expect_equal(length(rpred_trunc), ns) - expect_true(all(rpred_trunc >= prep$data$lb[i] & rpred_trunc <= prep$data$ub[i])) - - PITs_trunc <- brms:::posterior_predict_poisson(i, prep = prep, output = "pit") - expect_equal(length(PITs_trunc), ns) - expect_true(all(PITs_trunc >= 0 & PITs_trunc <= 1)) + prep <- make_prep_outcome_discrete() + + family_specs <- list( + bernoulli = list(fun = brms:::posterior_predict_bernoulli, q_ref = 1), + binomial = list(fun = brms:::posterior_predict_binomial, q_ref = 3), + beta_binomial = list(fun = brms:::posterior_predict_beta_binomial, q_ref = 3), + poisson = list(fun = brms:::posterior_predict_poisson, q_ref = 3), + negbinomial = list(fun = brms:::posterior_predict_negbinomial, q_ref = 3), + negbinomial2 = list(fun = brms:::posterior_predict_negbinomial2, q_ref = 3), + geometric = list(fun = brms:::posterior_predict_geometric, q_ref = 3), + com_poisson = list(fun = brms:::posterior_predict_com_poisson, q_ref = 3), + zero_inflated_poisson = list( + fun = brms:::posterior_predict_zero_inflated_poisson, q_ref = 3 + ), + zero_inflated_binomial = list( + fun = brms:::posterior_predict_zero_inflated_binomial, q_ref = 3 + ), + zero_inflated_beta_binomial = list( + fun = brms:::posterior_predict_zero_inflated_beta_binomial, q_ref = 3 + ), + zero_inflated_negbinomial = list( + fun = brms:::posterior_predict_zero_inflated_negbinomial, q_ref = 3 + ) + ) + + for (spec in family_specs) { + expect_outcome_modes( + family_fun = spec$fun, + prep = prep, + i = i, + q_ref = spec$q_ref, + p_ref = 0.81, + support = c(0, Inf), + check_integer = TRUE + ) + } }) test_that("compute_cdf returns correct CDF for non-truncated distributions", { @@ -650,13 +661,6 @@ test_that("compute_cdf returns correct CDF for non-truncated distributions", { expect_equal(out, pbinom(q, size = 10, prob = 0.5)) }) -test_that("compute_cdf with randomized = FALSE returns value in [0, 1]", { - q <- 5 - out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, - randomized = FALSE, lambda = 3) - expect_true(out >= 0 && out <= 1) -}) - test_that("compute_cdf with randomized = TRUE returns value in [F(q-1), F(q)]", { # Randomized PIT: F(y-1) + V * [F(y) - F(y-1)] with V ~ Unif(0,1) set.seed(42) @@ -664,13 +668,14 @@ test_that("compute_cdf with randomized = TRUE returns value in [F(q-1), F(q)]", Fq <- ppois(q, lambda = 3) Fqm1 <- ppois(q - 1, lambda = 3) - out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, randomized = TRUE, - lambda = 3) + out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, + randomized = TRUE, lambda = 3) expect_true(out >= Fqm1) expect_true(out <= Fq) }) -test_that("compute_cdf with randomized = TRUE and truncation returns value in valid range", { +test_that("compute_cdf with randomized = TRUE and truncation returns value in +valid range", { set.seed(123) q <- 4 lb <- 2 @@ -679,19 +684,22 @@ test_that("compute_cdf with randomized = TRUE and truncation returns value in va Fq <- (ppois(q, lambda = 5) - ppois(lb, lambda = 5)) / denom Fqm1 <- (ppois(q - 1, lambda = 5) - ppois(lb, lambda = 5)) / denom - out <- brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, randomized = TRUE, lambda = 5) + out <- brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, + randomized = TRUE, lambda = 5) expect_true(out >= Fqm1) expect_true(out <= Fq) expect_true(out >= 0 && out <= 1) }) -test_that("compute_cdf handles zero denominator (lb == ub) without unexpected behaviour", { +test_that("compute_cdf handles zero denominator (lb == ub) without unexpected +behaviour", { q <- 3 lb <- 1 ub <- 1 out <- tryCatch( - brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, randomized = FALSE, lambda = 2), + brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, + randomized = FALSE, lambda = 2), error = function(e) structure(list(error = TRUE, message = e$message)) ) @@ -702,36 +710,6 @@ test_that("compute_cdf handles zero denominator (lb == ub) without unexpected be } }) -test_that("zero_inflated_negative_binomial", { - ns <- 50 - nobs <- 8 - trials <- sample(10:30, nobs, replace = TRUE) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - eta = matrix(rnorm(ns * nobs * 2), ncol = nobs * 2), - shape = rgamma(ns, 4), phi = rgamma(ns, 1), - zi = rbeta(ns, 1, 1), coi = rbeta(ns, 5, 7) - ) - prep$dpars$mu <- prep$dpars$zi*30 - prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi - y_rand <- rnbinom(ns, size = trials, mu = prep$dpars$mu) - tmp <- runif(ns, 0, 1) - prep$data <- list( - Y = ifelse(tmp < prep$dpars$zi, 0L, y_rand), - trials = trials - ) - i <- 6 - - PITs <- brms:::posterior_predict_zero_inflated_negbinomial(i, prep = prep, - output = "pit") - expect_equal(length(PITs), ns) - expect_true(all(PITs >= 0 & PITs <= 1)) - - probs <- brms:::posterior_predict_zero_inflated_negbinomial(i, prep = prep, - output = "probability") - expect_equal(length(probs), ns) - expect_true(all(probs >= 0 & probs <= 1)) -}) test_that("compute_cdf respects lower.tail and log.p", { q <- 0.4 diff --git a/tests/testthat/tests.posterior_predict_density_quantile.R b/tests/testthat/tests.posterior_predict_density_quantile.R deleted file mode 100644 index 8648d1d5f..000000000 --- a/tests/testthat/tests.posterior_predict_density_quantile.R +++ /dev/null @@ -1,215 +0,0 @@ -context("Validation tests for posterior_predict density and quantile outputs") - -skip_if_density_quantile_not_available <- function() { - ns <- asNamespace("brms") - has_density <- exists("compute_density", envir = ns, inherits = FALSE) - has_quantile <- exists("compute_quantile", envir = ns, inherits = FALSE) - if (!(has_density && has_quantile)) { - testthat::skip("Density/quantile posterior_predict helpers are not available.") - } -} - -make_prep_gaussian <- function(ns = 120, nobs = 8) { - set.seed(1001) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rgamma(ns, shape = 4, rate = 3) - ) - prep$data <- list( - Y = rnorm(nobs), - lb = rep(NULL, nobs), - ub = rep(NULL, nobs) - ) - prep -} - -make_prep_student <- function(ns = 120, nobs = 8) { - set.seed(1002) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rgamma(ns, shape = 4, rate = 3), - nu = rgamma(ns, shape = 6, rate = 1) + 2 - ) - prep$data <- list( - Y = rnorm(nobs), - lb = rep(NULL, nobs), - ub = rep(NULL, nobs) - ) - prep -} - -make_prep_count <- function(ns = 150, nobs = 10) { - set.seed(1003) - trials <- sample(10:30, nobs, replace = TRUE) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(plogis(rnorm(ns * nobs)), ncol = nobs), - phi = rgamma(ns, shape = 5, rate = 1), - shape = rgamma(ns, shape = 4, rate = 1), - sigma = rgamma(ns, shape = 3, rate = 2), - zi = rbeta(ns, 1.5, 5) - ) - prep$data <- list( - Y = rpois(nobs, lambda = 5), - trials = trials, - lb = rep(NULL, nobs), - ub = rep(NULL, nobs) - ) - prep -} - -test_that("continuous families: density matches finite-difference CDF", { - - h <- 1e-4 - i <- 3 - q_ref <- 0.25 - - prep_g <- make_prep_gaussian() - f_g <- brms:::posterior_predict_gaussian(i, - prep = prep_g, output = "density", q = q_ref) - F_plus_g <- brms:::posterior_predict_gaussian(i, - prep = prep_g, output = "probability", q = q_ref + h) - F_minus_g <- brms:::posterior_predict_gaussian(i, - prep = prep_g, output = "probability", q = q_ref - h) - fd_g <- (F_plus_g - F_minus_g) / (2 * h) - expect_equal(f_g, fd_g, tolerance = 1e-3) - - prep_t <- make_prep_student() - f_t <- brms:::posterior_predict_student(i, - prep = prep_t, output = "density", q = q_ref) - F_plus_t <- brms:::posterior_predict_student(i, - prep = prep_t, output = "probability", q = q_ref + h) - F_minus_t <- brms:::posterior_predict_student(i, - prep = prep_t, output = "probability", q = q_ref - h) - fd_t <- (F_plus_t - F_minus_t) / (2 * h) - expect_equal(f_t, fd_t, tolerance = 2e-3) -}) - -test_that("density output supports log = TRUE", { - - i <- 3 - q_ref <- 0.25 - prep_g <- make_prep_gaussian() - - dens <- brms:::posterior_predict_gaussian( - i, prep = prep_g, output = "density", q = q_ref, log = FALSE - ) - log_dens <- brms:::posterior_predict_gaussian( - i, prep = prep_g, output = "density", q = q_ref, log = TRUE - ) - - expect_equal(log_dens, log(dens), tolerance = 1e-10) -}) - -test_that("discrete families: density matches CDF increments", { - - i <- 4 - q_ref <- 3 - prep <- make_prep_count() - - check_density_increment <- function(family_fun, ...) { - dens <- family_fun(i, prep = prep, output = "density", q = q_ref, ...) - F_q <- family_fun(i, prep = prep, output = "probability", q = q_ref, ...) - F_qm1 <- family_fun(i, prep = prep, output = "probability", q = q_ref - 1, ...) - expect_equal(dens, F_q - F_qm1, tolerance = 1e-10) - } - - check_density_increment(brms:::posterior_predict_binomial) - check_density_increment(brms:::posterior_predict_beta_binomial) - check_density_increment(brms:::posterior_predict_poisson) - check_density_increment(brms:::posterior_predict_negbinomial) - check_density_increment(brms:::posterior_predict_negbinomial2) - check_density_increment(brms:::posterior_predict_zero_inflated_negbinomial) -}) - -test_that("quantile output inverts probability output (continuous)", { - - i <- 2 - p_ref <- 0.73 - - prep_g <- make_prep_gaussian() - q_g <- brms:::posterior_predict_gaussian(i, prep = prep_g, - output = "quantile", p = p_ref) - F_q_g <- brms:::posterior_predict_gaussian(i, prep = prep_g, - output = "probability", q = q_g) - expect_equal(F_q_g, rep(p_ref, length(F_q_g)), tolerance = 1e-8) - - prep_t <- make_prep_student() - q_t <- brms:::posterior_predict_student(i, prep = prep_t, - output = "quantile", p = p_ref) - F_q_t <- brms:::posterior_predict_student(i, prep = prep_t, - output = "probability", q = q_t) - expect_equal(F_q_t, rep(p_ref, length(F_q_t)), tolerance = 1e-8) -}) - -test_that("quantile output inverts CDF inequalities (discrete)", { - skip_if_density_quantile_not_available() - - i <- 5 - p_ref <- 0.81 - prep <- make_prep_count() - - check_quantile_discrete <- function(family_fun, ...) { - q <- family_fun(i, prep = prep, output = "quantile", p = p_ref, ...) - F_q <- family_fun(i, prep = prep, output = "probability", q = q, ...) - F_qm1 <- family_fun(i, prep = prep, output = "probability", q = q - 1, ...) - - expect_true(all(F_q >= p_ref)) - expect_true(all(F_qm1 < p_ref)) - } - - check_quantile_discrete(brms:::posterior_predict_binomial) - check_quantile_discrete(brms:::posterior_predict_beta_binomial) - check_quantile_discrete(brms:::posterior_predict_poisson) - check_quantile_discrete(brms:::posterior_predict_negbinomial) - check_quantile_discrete(brms:::posterior_predict_negbinomial2) - check_quantile_discrete(brms:::posterior_predict_zero_inflated_negbinomial) -}) - -test_that("quantile output supports lower.tail and log.p", { - - i <- 2 - prep_g <- make_prep_gaussian() - p_ref <- 0.2 - - q_upper <- brms:::posterior_predict_gaussian( - i, prep = prep_g, output = "quantile", - p = p_ref, lower.tail = FALSE, log.p = FALSE - ) - F_upper <- brms:::posterior_predict_gaussian( - i, prep = prep_g, output = "probability", - q = q_upper, lower.tail = FALSE, log.p = FALSE - ) - expect_equal(F_upper, rep(p_ref, length(F_upper)), tolerance = 1e-8) - - q_log <- brms:::posterior_predict_gaussian( - i, prep = prep_g, output = "quantile", - p = log(p_ref), lower.tail = TRUE, log.p = TRUE - ) - F_log <- brms:::posterior_predict_gaussian( - i, prep = prep_g, output = "probability", - q = q_log, lower.tail = TRUE, log.p = FALSE - ) - expect_equal(F_log, rep(p_ref, length(F_log)), tolerance = 1e-8) -}) - -test_that("random baseline agrees with density for selected discrete families", { - - set.seed(1234) - i <- 6 - q_ref <- 2 - prep <- make_prep_count(ns = 4000, nobs = 10) - - check_random_baseline <- function(family_fun, ...) { - draws <- family_fun(i, prep = prep, output = "random", ...) - p_emp <- mean(draws == q_ref) - p_dens <- mean(family_fun(i, prep = prep, output = "density", q = q_ref, ...)) - expect_equal(p_emp, p_dens, tolerance = 0.03) - } - - check_random_baseline(brms:::posterior_predict_binomial) - check_random_baseline(brms:::posterior_predict_poisson) - check_random_baseline(brms:::posterior_predict_negbinomial) -}) From 3ed2381c9c27681c4478fa742ce089345d45c073 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 10:57:35 +0300 Subject: [PATCH 41/63] support of different output types for shifted_lognormal, skew_normal, geometric, disc_weibull, exp, frechet, gen_extr_val, xbeta, asym_laplace --- R/posterior_predict.R | 131 ++++++++++++----------- tests/testthat/tests.posterior_predict.R | 47 +++++++- 2 files changed, 114 insertions(+), 64 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 27bce8eab..b3d4bd91c 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -366,27 +366,28 @@ posterior_predict_lognormal <- function(i, prep, output = "random", ) } -posterior_predict_shifted_lognormal <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "shifted_lnorm", - meanlog = get_dpar(prep, "mu", i = i), - sdlog = get_dpar(prep, "sigma", i = i), - shift = get_dpar(prep, "ndt", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_shifted_lognormal <- function(i, prep, output = "random", + ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + ndt <- get_dpar(prep, "ndt", i = i) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "shifted_lnorm", meanlog = mu, sdlog = sigma, shift = ndt, ... ) } -posterior_predict_skew_normal <- function(i, prep, ntrys = 5, ...) { +posterior_predict_skew_normal <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) alpha <- get_dpar(prep, "alpha", i = i) - rcontinuous( - n = prep$ndraws, dist = "skew_normal", - mu = mu, sigma = sigma, alpha = alpha, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "skew_normal", mu = mu, sigma = sigma, alpha = alpha, ... ) } @@ -575,26 +576,27 @@ posterior_predict_negbinomial2 <- function(i, prep, output = "random", ) } -posterior_predict_geometric <- function(i, prep, ntrys = 5, ...) { +posterior_predict_geometric <- function(i, prep, output = "random", + ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- 1 shape <- multiply_dpar_rate_denom(shape, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "nbinom", - mu = mu, size = shape, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "nbinom", mu = mu, size = shape, ... ) } -posterior_predict_discrete_weibull <- function(i, prep, ntrys = 5, ...) { - rdiscrete( - n = prep$ndraws, dist = "discrete_weibull", - mu = get_dpar(prep, "mu", i = i), - shape = get_dpar(prep, "shape", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_discrete_weibull <- function(i, prep, output = "random", + ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + shape <- get_dpar(prep, "shape", i = i) + + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "discrete_weibull", mu = mu, shape = shape, ... ) } @@ -608,12 +610,14 @@ posterior_predict_com_poisson <- function(i, prep, ntrys = 5, ...) { ) } -posterior_predict_exponential <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "exp", - rate = 1 / get_dpar(prep, "mu", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_exponential <- function(i, prep, output = "random", + ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + rate <- 1 / mu + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "exp", rate = rate, ... ) } @@ -639,25 +643,27 @@ posterior_predict_weibull <- function(i, prep, output = "random", ) } -posterior_predict_frechet <- function(i, prep, ntrys = 5, ...) { +posterior_predict_frechet <- function(i, prep, output = "random", + ntrys = 5, ...) { nu <- get_dpar(prep, "nu", i = i) - scale <- get_dpar(prep, "mu", i = i) / gamma(1 - 1 / nu) - rcontinuous( - n = prep$ndraws, dist = "frechet", - scale = scale, shape = nu, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + mu <- get_dpar(prep, "mu", i = i) + scale <- mu / gamma(1 - 1 / nu) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "frechet", scale = scale, shape = nu, ... ) } -posterior_predict_gen_extreme_value <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "gen_extreme_value", - sigma = get_dpar(prep, "sigma", i = i), - xi = get_dpar(prep, "xi", i = i), - mu = get_dpar(prep, "mu", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_gen_extreme_value <- function(i, prep, output = "random", + ntrys = 5, ...) { + sigma <- get_dpar(prep, "sigma", i = i) + xi <- get_dpar(prep, "xi", i = i) + mu <- get_dpar(prep, "mu", i = i) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "gen_extreme_value", sigma = sigma, xi = xi, mu = mu, ... ) } @@ -711,16 +717,14 @@ posterior_predict_beta <- function(i, prep, output = "random", ntrys = 5, ...) { ) } -posterior_predict_xbeta <- function(i, prep, ntrys = 5, ...) { +posterior_predict_xbeta <- function(i, prep, output = "random", ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) kappa <- get_dpar(prep, "kappa", i = i) - rcontinuous( - n = prep$ndraws, - dist = "xbeta", - mu = mu, phi = phi, nu = kappa, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "xbeta", mu = mu, phi = phi, nu = kappa, ... ) } @@ -734,14 +738,15 @@ posterior_predict_von_mises <- function(i, prep, ntrys = 5, ...) { ) } -posterior_predict_asym_laplace <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "asym_laplace", - mu = get_dpar(prep, "mu", i = i), - sigma = get_dpar(prep, "sigma", i = i), - quantile = get_dpar(prep, "quantile", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_asym_laplace <- function(i, prep, output = "random", + ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + quantile <- get_dpar(prep, "quantile", i = i) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "asym_laplace", mu = mu, sigma = sigma, quantile = quantile, ... ) } diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 069101491..c6ff06375 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -479,7 +479,14 @@ make_prep_positive_outcome <- function(ns = 120, nobs = 8) { dpars = list( mu = matrix(exp(rnorm(ns * nobs, mean = 0.2, sd = 0.4)), ncol = nobs), sigma = rgamma(ns, shape = 4, rate = 3), - shape = rgamma(ns, shape = 6, rate = 2) + 0.5 + shape = rgamma(ns, shape = 6, rate = 2) + 0.5, + ndt = runif(ns, min = 0, max = 0.5), + alpha = rnorm(ns), + nu = rgamma(ns, shape = 4, rate = 1) + 2, + xi = rnorm(ns, sd = 0.3), + quantile = runif(ns, min = 0.2, max = 0.8), + phi = rgamma(ns, shape = 5, rate = 1), + kappa = rgamma(ns, shape = 2, rate = 1) ), data = list(Y = rgamma(nobs, shape = 2, rate = 1)) ) @@ -491,6 +498,7 @@ make_prep_beta_outcome <- function(ns = 140, nobs = 9) { dpars = list( mu = matrix(plogis(rnorm(ns * nobs)), ncol = nobs), phi = rgamma(ns, shape = 5, rate = 1), + kappa = rgamma(ns, shape = 2, rate = 1), zi = rbeta(ns, 1.5, 5), zoi = rbeta(ns, 1.5, 5), coi = rbeta(ns, 2, 6) @@ -582,6 +590,34 @@ test_that("posterior_predict outcome argument works for continuous families", { fun = brms:::posterior_predict_weibull, q_ref = 1.2, p_ref = 0.73, support = c(0, Inf), prep = make_prep_positive_outcome() ), + exponential = list( + fun = brms:::posterior_predict_exponential, q_ref = 1.2, p_ref = 0.73, + support = c(0, Inf), prep = make_prep_positive_outcome() + ), + shifted_lognormal = list( + fun = brms:::posterior_predict_shifted_lognormal, q_ref = 1.2, p_ref = 0.73, + support = c(0, Inf), prep = make_prep_positive_outcome() + ), + skew_normal = list( + fun = brms:::posterior_predict_skew_normal, q_ref = 0.25, p_ref = 0.73, + support = c(-Inf, Inf), prep = make_prep_positive_outcome() + ), + frechet = list( + fun = brms:::posterior_predict_frechet, q_ref = 1.2, p_ref = 0.73, + support = c(0, Inf), prep = make_prep_positive_outcome() + ), + gen_extreme_value = list( + fun = brms:::posterior_predict_gen_extreme_value, q_ref = 0.25, p_ref = 0.73, + support = c(-Inf, Inf), prep = make_prep_positive_outcome() + ), + asym_laplace = list( + fun = brms:::posterior_predict_asym_laplace, q_ref = 0.25, p_ref = 0.73, + support = c(-Inf, Inf), prep = make_prep_positive_outcome() + ), + xbeta = list( + fun = brms:::posterior_predict_xbeta, q_ref = 0.4, p_ref = 0.73, + support = c(0, 1), prep = make_prep_beta_outcome(), requires = "betareg" + ), beta = list( fun = brms:::posterior_predict_beta, q_ref = 0.4, p_ref = 0.73, support = c(0, 1), prep = make_prep_beta_outcome() @@ -597,6 +633,9 @@ test_that("posterior_predict outcome argument works for continuous families", { ) for (spec in family_specs) { + if (!is.null(spec$requires)) { + skip_if_not_installed(spec$requires) + } expect_outcome_modes( family_fun = spec$fun, prep = spec$prep, @@ -620,6 +659,9 @@ test_that("posterior_predict outcome argument works for discrete families", { negbinomial = list(fun = brms:::posterior_predict_negbinomial, q_ref = 3), negbinomial2 = list(fun = brms:::posterior_predict_negbinomial2, q_ref = 3), geometric = list(fun = brms:::posterior_predict_geometric, q_ref = 3), + discrete_weibull = list( + fun = brms:::posterior_predict_discrete_weibull, q_ref = 3 + ), com_poisson = list(fun = brms:::posterior_predict_com_poisson, q_ref = 3), zero_inflated_poisson = list( fun = brms:::posterior_predict_zero_inflated_poisson, q_ref = 3 @@ -636,6 +678,9 @@ test_that("posterior_predict outcome argument works for discrete families", { ) for (spec in family_specs) { + if (!is.null(spec$requires)) { + skip_if_not_installed(spec$requires) + } expect_outcome_modes( family_fun = spec$fun, prep = prep, From aa2127727744d0c4003b94b1925c7b49f7678866 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 11:54:58 +0300 Subject: [PATCH 42/63] feat: add qcom_poisson and output arg to posterior_predict_com_poisson --- R/distributions.R | 88 +++++++++++++------ R/posterior_predict.R | 15 ++-- .../tests.distributions_quantile_outputs.R | 45 ++++++++++ 3 files changed, 115 insertions(+), 33 deletions(-) diff --git a/R/distributions.R b/R/distributions.R index 4bcca4b4c..3a447ceba 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -1263,32 +1263,7 @@ dcom_poisson <- function(x, mu, shape, log = FALSE) { # random numbers from the COM-Poisson distribution rcom_poisson <- function(n, mu, shape, M = 10000) { n <- check_n_rdist(n, mu, shape) - M <- as.integer(as_one_numeric(M)) - log_mu <- log(mu) - # approximating log_Z may yield too large random draws - log_Z <- log_Z_com_poisson(log_mu, shape, approx = FALSE) - u <- runif(n, 0, 1) - cdf <- exp(-log_Z) - lfac <- 0 - y <- 0 - out <- rep(0, n) - not_found <- cdf < u - while (any(not_found) && y <= M) { - y <- y + 1 - out[not_found] <- y - lfac <- lfac + log(y) - cdf <- cdf + exp(shape * (y * log_mu - lfac) - log_Z) - not_found <- cdf < u - } - if (any(not_found)) { - out[not_found] <- NA - nfailed <- sum(not_found) - warning2( - "Drawing random numbers from the 'com_poisson' ", - "distribution failed in ", nfailed, " cases." - ) - } - out + qcom_poisson(runif(n), mu, shape, M = M) } # CDF of the COM-Poisson distribution @@ -1323,6 +1298,67 @@ pcom_poisson <- function(x, mu, shape, lower.tail = TRUE, log.p = FALSE) { out } +# quantile function of the COM-Poisson distribution +qcom_poisson <- function(p, mu, shape, lower.tail = TRUE, log.p = FALSE, + M = 10000) { + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- expand(p = p, mu = mu, shape = shape) + p <- args$p + mu <- args$mu + shape <- args$shape + M <- as.integer(as_one_numeric(M)) + + out <- rep(NA_real_, length(p)) + dim(out) <- attributes(args)$max_dim + out[!is.finite(p)] <- p[!is.finite(p)] + + use_poisson <- is.finite(p) & shape == 1 + if (any(use_poisson)) { + out[use_poisson] <- qpois(p[use_poisson], lambda = mu[use_poisson]) + } + + use_inf <- is.finite(p) & p == 1 & shape != 1 + if (any(use_inf)) { + out[use_inf] <- Inf + } + + search_mask <- is.finite(p) & p < 1 & shape != 1 + if (!any(search_mask)) { + return(out) + } + + log_mu <- log(mu[search_mask]) + shape_t <- shape[search_mask] + p_t <- p[search_mask] + log_Z <- log_Z_com_poisson(log_mu, shape_t, approx = FALSE) + + cdf <- exp(-log_Z) + out_t <- rep(0, sum(search_mask)) + not_found <- cdf < p_t + + y <- 0 + lfac <- 0 + while (any(not_found) && y <= M) { + y <- y + 1 + out_t[not_found] <- y + lfac <- lfac + log(y) + cdf <- cdf + exp(shape_t * (y * log_mu - lfac) - log_Z) + not_found <- cdf < p_t + } + + if (any(not_found)) { + out_t[not_found] <- NA + nfailed <- sum(not_found) + warning2( + "Computing quantiles of the 'com_poisson' ", + "distribution failed in ", nfailed, " cases." + ) + } + + out[search_mask] <- out_t + out +} + # log normalizing constant of the COM Poisson distribution # @param log_mu log location parameter # @param shape shape parameter diff --git a/R/posterior_predict.R b/R/posterior_predict.R index b3d4bd91c..b3adc952c 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -600,13 +600,14 @@ posterior_predict_discrete_weibull <- function(i, prep, output = "random", ) } -posterior_predict_com_poisson <- function(i, prep, ntrys = 5, ...) { - rdiscrete( - n = prep$ndraws, dist = "com_poisson", - mu = get_dpar(prep, "mu", i = i), - shape = get_dpar(prep, "shape", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_com_poisson <- function(i, prep, output = "random", + ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + shape <- get_dpar(prep, "shape", i = i) + + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "com_poisson", mu = mu, shape = shape, ... ) } diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R index b92aa471e..87221de3c 100644 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -17,6 +17,29 @@ test_that("qbeta_binomial satisfies the discrete quantile definition", { expect_true(all(q >= 0 & q <= size)) }) +test_that("qcom_poisson satisfies the discrete quantile definition", { + mu <- 2 + shape <- 0.8 + p <- c(0.01, 0.1, 0.5, 0.85, 0.99) + + q <- brms:::qcom_poisson(p, mu = mu, shape = shape) + F_q <- brms:::pcom_poisson(q, mu = mu, shape = shape) + F_qm1 <- brms:::pcom_poisson(q - 1, mu = mu, shape = shape) + + expect_true(all(F_q >= p)) + expect_true(all(ifelse(q > 0, F_qm1 < p, TRUE))) + expect_true(all(q >= 0)) +}) + +test_that("qcom_poisson reduces to qpois when shape is 1", { + mu <- 3 + p <- c(0.1, 0.5, 0.9) + expect_equal( + brms:::qcom_poisson(p, mu = mu, shape = 1), + qpois(p, lambda = mu) + ) +}) + test_that("qzero_inflated_negbinomial satisfies the discrete quantile definition", { mu <- 4 shape <- 2.5 @@ -37,9 +60,11 @@ test_that("quantile functions are monotone in probability", { q_bb <- brms:::qbeta_binomial(p, size = 20, mu = 0.45, phi = 6) q_zinb <- brms:::qzero_inflated_negbinomial(p, mu = 5, shape = 2, zi = 0.25) + q_comp <- brms:::qcom_poisson(p, mu = 2, shape = 1.5) expect_true(all(diff(q_bb) >= 0)) expect_true(all(diff(q_zinb) >= 0)) + expect_true(all(diff(q_comp) >= 0)) }) test_that("quantile functions respect lower.tail and log.p", { @@ -64,4 +89,24 @@ test_that("quantile functions respect lower.tail and log.p", { lower.tail = TRUE, log.p = FALSE ) expect_equal(q_zinb_log, q_zinb_ref) + + q_comp_upper <- brms:::qcom_poisson( + p_ref, mu = 2, shape = 0.8, + lower.tail = FALSE, log.p = FALSE + ) + q_comp_lower <- brms:::qcom_poisson( + 1 - p_ref, mu = 2, shape = 0.8, + lower.tail = TRUE, log.p = FALSE + ) + expect_equal(q_comp_upper, q_comp_lower) + + q_comp_log <- brms:::qcom_poisson( + log(p_ref), mu = 2, shape = 0.8, + lower.tail = TRUE, log.p = TRUE + ) + q_comp_ref <- brms:::qcom_poisson( + p_ref, mu = 2, shape = 0.8, + lower.tail = TRUE, log.p = FALSE + ) + expect_equal(q_comp_log, q_comp_ref) }) From eafc2836c02b2ee2ef375c98c596507c17ebc758 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 13:58:38 +0300 Subject: [PATCH 43/63] chore: update NAMESPACE --- NAMESPACE | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 0eb2c1de9..a6e957233 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -562,10 +562,15 @@ export(qasym_laplace) export(qbeta_binomial) export(qfrechet) export(qgen_extreme_value) +export(qinv_gaussian) export(qshifted_lnorm) export(qskew_normal) export(qstudent_t) +export(qzero_inflated_beta) +export(qzero_inflated_beta_binomial) +export(qzero_inflated_binomial) export(qzero_inflated_negbinomial) +export(qzero_inflated_poisson) export(ranef) export(rasym_laplace) export(rbeta_binomial) From 182788899fbfe30a4e2ebd8dc37375ab2c224fb0 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 13:59:28 +0300 Subject: [PATCH 44/63] docs: update documentation for InvGaussian and ZeroInflated --- man/InvGaussian.Rd | 17 ++++++++++++++++- man/ZeroInflated.Rd | 24 ++++++++++++++++++++++-- 2 files changed, 38 insertions(+), 3 deletions(-) diff --git a/man/InvGaussian.Rd b/man/InvGaussian.Rd index 9fd023048..eba6086c6 100644 --- a/man/InvGaussian.Rd +++ b/man/InvGaussian.Rd @@ -4,6 +4,7 @@ \alias{InvGaussian} \alias{dinv_gaussian} \alias{pinv_gaussian} +\alias{qinv_gaussian} \alias{rinv_gaussian} \title{The Inverse Gaussian Distribution} \usage{ @@ -11,6 +12,15 @@ dinv_gaussian(x, mu = 1, shape = 1, log = FALSE) pinv_gaussian(q, mu = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) +qinv_gaussian( + p, + mu = 1, + shape = 1, + lower.tail = TRUE, + log.p = FALSE, + tol = 1e-08 +) + rinv_gaussian(n, mu = 1, shape = 1) } \arguments{ @@ -27,14 +37,19 @@ Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} +\item{p}{Vector of probabilities.} + \item{n}{Number of draws to sample from the distribution.} } \description{ -Density, distribution function, and random generation +Density, distribution function, quantile function and random generation for the inverse Gaussian distribution with location \code{mu}, and shape \code{shape}. } \details{ +The quantile function has no known closed form and is therefore computed +numerically via inversion of the cumulative distribution function. + See \code{vignette("brms_families")} for details on the parameterization. } diff --git a/man/ZeroInflated.Rd b/man/ZeroInflated.Rd index f85ed7520..cf535a043 100644 --- a/man/ZeroInflated.Rd +++ b/man/ZeroInflated.Rd @@ -4,21 +4,27 @@ \alias{ZeroInflated} \alias{dzero_inflated_poisson} \alias{pzero_inflated_poisson} +\alias{qzero_inflated_poisson} \alias{dzero_inflated_negbinomial} \alias{pzero_inflated_negbinomial} \alias{qzero_inflated_negbinomial} \alias{dzero_inflated_binomial} \alias{pzero_inflated_binomial} +\alias{qzero_inflated_binomial} \alias{dzero_inflated_beta_binomial} \alias{pzero_inflated_beta_binomial} +\alias{qzero_inflated_beta_binomial} \alias{dzero_inflated_beta} \alias{pzero_inflated_beta} +\alias{qzero_inflated_beta} \title{Zero-Inflated Distributions} \usage{ dzero_inflated_poisson(x, lambda, zi, log = FALSE) pzero_inflated_poisson(q, lambda, zi, lower.tail = TRUE, log.p = FALSE) +qzero_inflated_poisson(p, lambda, zi, lower.tail = TRUE, log.p = FALSE) + dzero_inflated_negbinomial(x, mu, shape, zi, log = FALSE) pzero_inflated_negbinomial(q, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) @@ -29,6 +35,8 @@ dzero_inflated_binomial(x, size, prob, zi, log = FALSE) pzero_inflated_binomial(q, size, prob, zi, lower.tail = TRUE, log.p = FALSE) +qzero_inflated_binomial(p, size, prob, zi, lower.tail = TRUE, log.p = FALSE) + dzero_inflated_beta_binomial(x, size, mu, phi, zi, log = FALSE) pzero_inflated_beta_binomial( @@ -41,9 +49,21 @@ pzero_inflated_beta_binomial( log.p = FALSE ) +qzero_inflated_beta_binomial( + p, + size, + mu, + phi, + zi, + lower.tail = TRUE, + log.p = FALSE +) + dzero_inflated_beta(x, shape1, shape2, zi, log = FALSE) pzero_inflated_beta(q, shape1, shape2, zi, lower.tail = TRUE, log.p = FALSE) + +qzero_inflated_beta(p, shape1, shape2, zi, lower.tail = TRUE, log.p = FALSE) } \arguments{ \item{x}{Vector of quantiles.} @@ -59,12 +79,12 @@ Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} +\item{p}{Vector of probabilities.} + \item{mu, lambda}{location parameter} \item{shape, shape1, shape2}{shape parameter} -\item{p}{Vector of probabilities.} - \item{size}{number of trials} \item{prob}{probability of success on each trial} From 6bf75095bfcca8f95021798a51e14b86204e8740 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 14:00:16 +0300 Subject: [PATCH 45/63] feat: add qinv_gaussian and update posterior_predict_inverse.gaussian --- R/distributions.R | 45 +++++++++++++++++++++++- R/posterior_predict.R | 15 ++++---- tests/testthat/tests.distributions.R | 6 ++-- tests/testthat/tests.posterior_predict.R | 4 +++ 4 files changed, 60 insertions(+), 10 deletions(-) diff --git a/R/distributions.R b/R/distributions.R index 3a447ceba..c6bf7b145 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -824,10 +824,13 @@ rshifted_lnorm <- function(n, meanlog = 0, sdlog = 1, shift = 0) { #' The Inverse Gaussian Distribution #' -#' Density, distribution function, and random generation +#' Density, distribution function, quantile function and random generation #' for the inverse Gaussian distribution with location \code{mu}, #' and shape \code{shape}. #' +#' The quantile function has no known closed form and is therefore computed +#' numerically via inversion of the cumulative distribution function. +#' #' @name InvGaussian #' #' @inheritParams StudentT @@ -883,6 +886,46 @@ pinv_gaussian <- function(q, mu = 1, shape = 1, lower.tail = TRUE, out } +#' @rdname InvGaussian +#' @export +qinv_gaussian <- function(p, mu = 1, shape = 1, lower.tail = TRUE, + log.p = FALSE, tol = 1e-8) { + if (isTRUE(any(mu <= 0))) { + stop2("Argument 'mu' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- do_call(expand, nlist(p, mu, shape)) + out <- vapply(seq_along(args$p), function(i) { + p_i <- args$p[i] + if (!is.finite(p_i)) { + return(p_i) + } + if (p_i <= 0) { + return(0) + } + if (p_i >= 1) { + return(Inf) + } + f <- function(x) { + pinv_gaussian(x, mu = args$mu[i], shape = args$shape[i]) - p_i + } + lo <- .Machine$double.eps + hi <- args$mu[i] + while (f(hi) < 0 && hi < 1e12) { + hi <- hi * 2 + } + if (f(lo) * f(hi) > 0) { + return(NA_real_) + } + uniroot(f, c(lo, hi), tol = tol)$root + }, numeric(1)) + dim(out) <- attributes(args)$max_dim + out +} + #' @rdname InvGaussian #' @export rinv_gaussian <- function(n, mu = 1, shape = 1) { diff --git a/R/posterior_predict.R b/R/posterior_predict.R index b3adc952c..47b039794 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -668,13 +668,14 @@ posterior_predict_gen_extreme_value <- function(i, prep, output = "random", ) } -posterior_predict_inverse.gaussian <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "inv_gaussian", - mu = get_dpar(prep, "mu", i = i), - shape = get_dpar(prep, "shape", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_inverse.gaussian <- function(i, prep, output = "random", + ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + shape <- get_dpar(prep, "shape", i = i) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "inv_gaussian", mu = mu, shape = shape, ... ) } diff --git a/tests/testthat/tests.distributions.R b/tests/testthat/tests.distributions.R index 3e0d6e13f..f04c60a31 100644 --- a/tests/testthat/tests.distributions.R +++ b/tests/testthat/tests.distributions.R @@ -108,8 +108,10 @@ test_that("inv_gaussian distribution functions run without errors", { x <- rgamma(n, 10, 3) res <- dinv_gaussian(x, mu = 1, shape = 1) expect_true(length(res) == n) - res <- pinv_gaussian(x, mu = abs(rnorm(n)), shape = 3) - expect_true(length(res) == n) + mu <- abs(rnorm(n)) + 0.1 + p <- runif(n, 0.01, 0.99) + q <- qinv_gaussian(p, mu = mu, shape = 3) + expect_equal(pinv_gaussian(q, mu = mu, shape = 3), p, tolerance = 1e-8) res <- rinv_gaussian(n, mu = abs(rnorm(n)), shape = 1:10) expect_true(length(res) == n) }) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index c6ff06375..729bbc4a0 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -606,6 +606,10 @@ test_that("posterior_predict outcome argument works for continuous families", { fun = brms:::posterior_predict_frechet, q_ref = 1.2, p_ref = 0.73, support = c(0, Inf), prep = make_prep_positive_outcome() ), + inverse_gaussian = list( + fun = brms:::posterior_predict_inverse.gaussian, q_ref = 1.2, p_ref = 0.73, + support = c(0, Inf), prep = make_prep_positive_outcome() + ), gen_extreme_value = list( fun = brms:::posterior_predict_gen_extreme_value, q_ref = 0.25, p_ref = 0.73, support = c(-Inf, Inf), prep = make_prep_positive_outcome() From 4785458dfd7422fc52ab58c5e2d05b5a0b611196 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 14:11:38 +0300 Subject: [PATCH 46/63] feat: add qexgaussian and update posterior_predict_exgaussian --- NAMESPACE | 1 + R/distributions.R | 48 +++++++++++++++++++++++- R/posterior_predict.R | 19 +++++----- man/ExGaussian.Rd | 7 +++- tests/testthat/tests.distributions.R | 17 ++++++++- tests/testthat/tests.posterior_predict.R | 5 +++ 6 files changed, 84 insertions(+), 13 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a6e957233..9886b1fba 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -560,6 +560,7 @@ export(pzero_inflated_negbinomial) export(pzero_inflated_poisson) export(qasym_laplace) export(qbeta_binomial) +export(qexgaussian) export(qfrechet) export(qgen_extreme_value) export(qinv_gaussian) diff --git a/R/distributions.R b/R/distributions.R index c6bf7b145..a2c816b81 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -610,7 +610,7 @@ rvon_mises <- function(n, mu, kappa) { #' The Exponentially Modified Gaussian Distribution #' -#' Density, distribution function, and random generation +#' Density, distribution function, quantile function, and random generation #' for the exponentially modified Gaussian distribution with #' mean \code{mu} and standard deviation \code{sigma} of the gaussian #' component, as well as scale \code{beta} of the exponential @@ -679,6 +679,52 @@ pexgaussian <- function(q, mu, sigma, beta, out } +#' @rdname ExGaussian +#' @export +qexgaussian <- function(p, mu, sigma, beta, lower.tail = TRUE, log.p = FALSE, + tol = 1e-8) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + if (isTRUE(any(beta < 0))) { + stop2("beta must be non-negative.") + } + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- do_call(expand, nlist(p, mu, sigma, beta)) + out <- vapply(seq_along(args$p), function(i) { + p_i <- args$p[i] + if (!is.finite(p_i)) { + return(p_i) + } + if (p_i <= 0) { + return(-Inf) + } + if (p_i >= 1) { + return(Inf) + } + f <- function(x) { + pexgaussian(x, mu = args$mu[i], sigma = args$sigma[i], + beta = args$beta[i]) - p_i + } + sd <- sqrt(args$sigma[i]^2 + args$beta[i]^2) + center <- qnorm(p_i, mean = args$mu[i], sd = sd) + lo <- center - sd + hi <- center + sd + while (f(lo) > 0 && lo > -1e12) { + lo <- lo - sd + } + while (f(hi) < 0 && hi < 1e12) { + hi <- hi + sd + } + if (f(lo) * f(hi) > 0) { + return(NA_real_) + } + uniroot(f, c(lo, hi), tol = tol)$root + }, numeric(1)) + dim(out) <- attributes(args)$max_dim + out +} + #' @rdname ExGaussian #' @export rexgaussian <- function(n, mu, sigma, beta) { diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 47b039794..f5caee0d5 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -661,7 +661,7 @@ posterior_predict_gen_extreme_value <- function(i, prep, output = "random", sigma <- get_dpar(prep, "sigma", i = i) xi <- get_dpar(prep, "xi", i = i) mu <- get_dpar(prep, "mu", i = i) - + predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, dist = "gen_extreme_value", sigma = sigma, xi = xi, mu = mu, ... @@ -679,14 +679,15 @@ posterior_predict_inverse.gaussian <- function(i, prep, output = "random", ) } -posterior_predict_exgaussian <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "exgaussian", - mu = get_dpar(prep, "mu", i = i), - sigma = get_dpar(prep, "sigma", i = i), - beta = get_dpar(prep, "beta", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_exgaussian <- function(i, prep, output = "random", ntrys = 5, + ...) { + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + beta <- get_dpar(prep, "beta", i = i) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "exgaussian", mu = mu, sigma = sigma, beta = beta, ... ) } diff --git a/man/ExGaussian.Rd b/man/ExGaussian.Rd index 82de772af..ecc55163a 100644 --- a/man/ExGaussian.Rd +++ b/man/ExGaussian.Rd @@ -4,6 +4,7 @@ \alias{ExGaussian} \alias{dexgaussian} \alias{pexgaussian} +\alias{qexgaussian} \alias{rexgaussian} \title{The Exponentially Modified Gaussian Distribution} \usage{ @@ -11,6 +12,8 @@ dexgaussian(x, mu, sigma, beta, log = FALSE) pexgaussian(q, mu, sigma, beta, lower.tail = TRUE, log.p = FALSE) +qexgaussian(p, mu, sigma, beta, lower.tail = TRUE, log.p = FALSE, tol = 1e-08) + rexgaussian(n, mu, sigma, beta) } \arguments{ @@ -29,10 +32,12 @@ Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} +\item{p}{Vector of probabilities.} + \item{n}{Number of draws to sample from the distribution.} } \description{ -Density, distribution function, and random generation +Density, distribution function, quantile function, and random generation for the exponentially modified Gaussian distribution with mean \code{mu} and standard deviation \code{sigma} of the gaussian component, as well as scale \code{beta} of the exponential diff --git a/tests/testthat/tests.distributions.R b/tests/testthat/tests.distributions.R index f04c60a31..c33569ec1 100644 --- a/tests/testthat/tests.distributions.R +++ b/tests/testthat/tests.distributions.R @@ -79,9 +79,22 @@ test_that("exgaussian distribution functions run without errors", { x <- rnorm(n, 10, 3) res <- dexgaussian(x, mu = 1, sigma = 2, beta = 1) expect_true(length(res) == n) - res <- pexgaussian(x, mu = rnorm(n), sigma = 1:n, - beta = 3, log.p = TRUE) + mu <- rnorm(n) + res <- pexgaussian(x, mu = mu, sigma = 1:n, beta = 3, log.p = TRUE) expect_true(length(res) == n) + p <- runif(n, 0.01, 0.99) + q <- qexgaussian(p, mu = mu, sigma = 1:n, beta = 3) + expect_equal(pexgaussian(q, mu = mu, sigma = 1:n, beta = 3), p, + tolerance = 1e-8) + ps <- c(-1, 0, 1, 1.5) + res <- SW(qexgaussian(ps, mu = 1, sigma = 2, beta = 1)) + expect_equal(res, c(NA, -Inf, Inf, NA)) + expect_equal( + pexgaussian(qexgaussian(0.5, mu = 1, sigma = 2, beta = 1), + mu = 1, sigma = 2, beta = 1), + 0.5, + tolerance = 1e-8 + ) res <- rexgaussian(n, mu = rnorm(n), sigma = 10, beta = 1:10) expect_true(length(res) == n) }) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 729bbc4a0..9330d20cd 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -479,6 +479,7 @@ make_prep_positive_outcome <- function(ns = 120, nobs = 8) { dpars = list( mu = matrix(exp(rnorm(ns * nobs, mean = 0.2, sd = 0.4)), ncol = nobs), sigma = rgamma(ns, shape = 4, rate = 3), + beta = rgamma(ns, shape = 4, rate = 3), shape = rgamma(ns, shape = 6, rate = 2) + 0.5, ndt = runif(ns, min = 0, max = 0.5), alpha = rnorm(ns), @@ -606,6 +607,10 @@ test_that("posterior_predict outcome argument works for continuous families", { fun = brms:::posterior_predict_frechet, q_ref = 1.2, p_ref = 0.73, support = c(0, Inf), prep = make_prep_positive_outcome() ), + exgaussian = list( + fun = brms:::posterior_predict_exgaussian, q_ref = 1.2, p_ref = 0.73, + support = c(-Inf, Inf), prep = make_prep_positive_outcome() + ), inverse_gaussian = list( fun = brms:::posterior_predict_inverse.gaussian, q_ref = 1.2, p_ref = 0.73, support = c(0, Inf), prep = make_prep_positive_outcome() From dfe82bf51f73e1af5882699e2fd1a16a22c80687 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 14:24:28 +0300 Subject: [PATCH 47/63] feat: add qvon_mises and update posterior_predict_von_mises --- NAMESPACE | 1 + R/distributions.R | 46 ++++++++++++++++++++++++++-- R/posterior_predict.R | 15 ++++----- man/VonMises.Rd | 21 +++++++++++-- tests/testthat/tests.distributions.R | 9 ++++++ 5 files changed, 81 insertions(+), 11 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 9886b1fba..27fc7e53c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -567,6 +567,7 @@ export(qinv_gaussian) export(qshifted_lnorm) export(qskew_normal) export(qstudent_t) +export(qvon_mises) export(qzero_inflated_beta) export(qzero_inflated_beta_binomial) export(qzero_inflated_binomial) diff --git a/R/distributions.R b/R/distributions.R index a2c816b81..a9d3357ff 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -455,8 +455,9 @@ pinvgamma <- function(q, shape, rate, lower.tail = TRUE, log.p = FALSE) { #' The von Mises Distribution #' -#' Density, distribution function, and random generation for the -#' von Mises distribution with location \code{mu}, and precision \code{kappa}. +#' Density, distribution function, quantile function and random generation +#' for the von Mises distribution with location \code{mu}, and precision +#' \code{kappa}. #' #' @name VonMises #' @@ -464,6 +465,8 @@ pinvgamma <- function(q, shape, rate, lower.tail = TRUE, log.p = FALSE) { #' @param x,q Vector of quantiles between \code{-pi} and \code{pi}. #' @param kappa Vector of precision values. #' @param acc Accuracy of numerical approximations. +#' @param tol Tolerance of the approximation used in the +#' quantile function. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. @@ -550,6 +553,45 @@ pvon_mises <- function(q, mu, kappa, lower.tail = TRUE, out } +#' @rdname VonMises +#' @export +qvon_mises <- function(p, mu, kappa, lower.tail = TRUE, log.p = FALSE, + acc = 1e-20, tol = 1e-8) { + if (isTRUE(any(kappa < 0))) { + stop2("kappa must be non-negative") + } + pi <- base::pi + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- do_call(expand, nlist(p, mu, kappa)) + eps <- 1e-10 + out <- vapply(seq_along(args$p), function(i) { + p_i <- args$p[i] + if (!is.finite(p_i)) { + return(p_i) + } + if (p_i <= 0) { + return(-pi) + } + if (p_i >= 1) { + return(pi) + } + if (args$kappa[i] == 0) { + return(-pi + 2 * pi * p_i) + } + f <- function(q) { + pvon_mises(q, mu = args$mu[i], kappa = args$kappa[i], acc = acc) - p_i + } + lo <- -pi + eps + hi <- pi - eps + if (f(lo) * f(hi) > 0) { + return(NA_real_) + } + uniroot(f, c(lo, hi), tol = tol)$root + }, numeric(1)) + dim(out) <- attributes(args)$max_dim + out +} + #' @rdname VonMises #' @export rvon_mises <- function(n, mu, kappa) { diff --git a/R/posterior_predict.R b/R/posterior_predict.R index f5caee0d5..adec6fe67 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -731,13 +731,14 @@ posterior_predict_xbeta <- function(i, prep, output = "random", ntrys = 5, ...) ) } -posterior_predict_von_mises <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "von_mises", - mu = get_dpar(prep, "mu", i = i), - kappa = get_dpar(prep, "kappa", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys +posterior_predict_von_mises <- function(i, prep, output = "random", ntrys = 5, + ...) { + mu <- get_dpar(prep, "mu", i = i) + kappa <- get_dpar(prep, "kappa", i = i) + + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "von_mises", mu = mu, kappa = kappa, ... ) } diff --git a/man/VonMises.Rd b/man/VonMises.Rd index 3431c9df9..23c5b377f 100644 --- a/man/VonMises.Rd +++ b/man/VonMises.Rd @@ -4,6 +4,7 @@ \alias{VonMises} \alias{dvon_mises} \alias{pvon_mises} +\alias{qvon_mises} \alias{rvon_mises} \title{The von Mises Distribution} \usage{ @@ -11,6 +12,16 @@ dvon_mises(x, mu, kappa, log = FALSE) pvon_mises(q, mu, kappa, lower.tail = TRUE, log.p = FALSE, acc = 1e-20) +qvon_mises( + p, + mu, + kappa, + lower.tail = TRUE, + log.p = FALSE, + acc = 1e-20, + tol = 1e-08 +) + rvon_mises(n, mu, kappa) } \arguments{ @@ -29,11 +40,17 @@ Else, return P(X > x) .} \item{acc}{Accuracy of numerical approximations.} +\item{p}{Vector of probabilities.} + +\item{tol}{Tolerance of the approximation used in the +quantile function.} + \item{n}{Number of draws to sample from the distribution.} } \description{ -Density, distribution function, and random generation for the -von Mises distribution with location \code{mu}, and precision \code{kappa}. +Density, distribution function, quantile function and random generation +for the von Mises distribution with location \code{mu}, and precision +\code{kappa}. } \details{ See \code{vignette("brms_families")} for details diff --git a/tests/testthat/tests.distributions.R b/tests/testthat/tests.distributions.R index c33569ec1..31be25673 100644 --- a/tests/testthat/tests.distributions.R +++ b/tests/testthat/tests.distributions.R @@ -51,6 +51,15 @@ test_that("von_mises distribution functions run without errors", { expect_true(length(res) == n) res <- pvon_mises(runif(n, -pi, pi), mu = rnorm(n), kappa = 0:(n-1)) expect_true(length(res) == n) + p <- runif(n, 0.01, 0.99) + mu <- rnorm(n) + kappa <- 0:(n - 1) + q <- qvon_mises(p, mu = mu, kappa = kappa) + expect_true(length(q) == n) + expect_equal(pvon_mises(q, mu = mu, kappa = kappa), p, tolerance = 1e-6) + ps <- c(-1, 0, 0.5, 1, 1.5) + res <- SW(qvon_mises(ps, mu = 0, kappa = 1)) + expect_equal(res, c(NA, -pi, qvon_mises(0.5, mu = 0, kappa = 1), pi, NA)) res <- rvon_mises(n, mu = rnorm(n), kappa = 0:(n-1)) expect_true(length(res) == n) }) From 6a3682ce9d5d26954b111611dcc978df4e0b4543 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 14:32:30 +0300 Subject: [PATCH 48/63] feat: adding .qhurdle helper and qhurdle_poisson --- NAMESPACE | 1 + R/distributions.R | 40 +++++++++++++++++++ man/Hurdle.Rd | 5 +++ tests/testthat/tests.distributions.R | 3 ++ .../tests.distributions_quantile_outputs.R | 14 +++++++ 5 files changed, 63 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 27fc7e53c..4a2f15809 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -563,6 +563,7 @@ export(qbeta_binomial) export(qexgaussian) export(qfrechet) export(qgen_extreme_value) +export(qhurdle_poisson) export(qinv_gaussian) export(qshifted_lnorm) export(qskew_normal) diff --git a/R/distributions.R b/R/distributions.R index a9d3357ff..a26ade4db 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2217,6 +2217,14 @@ phurdle_poisson <- function(q, lambda, hu, lower.tail = TRUE, .phurdle(q, "pois", hu, pars, lower.tail, log.p, type = "int") } +#' @rdname Hurdle +#' @export +qhurdle_poisson <- function(p, lambda, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(lambda) + .qhurdle(p, "pois", hu, pars, lower.tail, log.p, type = "int") +} + #' @rdname Hurdle #' @export dhurdle_negbinomial <- function(x, mu, shape, hu, log = FALSE) { @@ -2337,6 +2345,38 @@ phurdle_lognormal <- function(q, mu, sigma, hu, lower.tail = TRUE, out } +# quantile function of a hurdle distribution +# @param dist name of the distribution +# @param hu bernoulli hurdle parameter +# @param pars list of parameters passed to qfun +# @param type support of distribution (int or real) +.qhurdle <- function(p, dist, hu, pars, lower.tail, log.p, type) { + stopifnot(is.list(pars)) + dist <- as_one_character(dist) + lower.tail <- as_one_logical(lower.tail) + log.p <- as_one_logical(log.p) + type <- match.arg(type, c("int", "real")) + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- expand(dots = c(nlist(p, hu), pars)) + p <- args$p + hu <- args$hu + pars <- args[names(pars)] + qfun <- paste0("q", dist) + if (type == "int") { + pdf <- paste0("d", dist) + cdf0 <- do_call(pdf, c(0, pars)) + p_dist <- cdf0 + (p - hu) / (1 - hu) * (1 - cdf0) + } else { + p_dist <- (p - hu) / (1 - hu) + } + p_dist <- ifelse(hu == 1, 0, p_dist) + p_dist <- pmin(1, pmax(0, p_dist)) + out <- do_call(qfun, c(list(p_dist), pars)) + out[!is.finite(p)] <- p[!is.finite(p)] + dim(out) <- attributes(args)$max_dim + out +} + # density of the categorical distribution with the softmax transform # @param x positive integers not greater than ncat # @param eta the linear predictor (of length or ncol ncat) diff --git a/man/Hurdle.Rd b/man/Hurdle.Rd index c904d7716..b1b35a28f 100644 --- a/man/Hurdle.Rd +++ b/man/Hurdle.Rd @@ -4,6 +4,7 @@ \alias{Hurdle} \alias{dhurdle_poisson} \alias{phurdle_poisson} +\alias{qhurdle_poisson} \alias{dhurdle_negbinomial} \alias{phurdle_negbinomial} \alias{dhurdle_gamma} @@ -16,6 +17,8 @@ dhurdle_poisson(x, lambda, hu, log = FALSE) phurdle_poisson(q, lambda, hu, lower.tail = TRUE, log.p = FALSE) +qhurdle_poisson(p, lambda, hu, lower.tail = TRUE, log.p = FALSE) + dhurdle_negbinomial(x, mu, shape, hu, log = FALSE) phurdle_negbinomial(q, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) @@ -42,6 +45,8 @@ Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} +\item{p}{Vector of probabilities.} + \item{mu, lambda}{location parameter} \item{shape}{shape parameter} diff --git a/tests/testthat/tests.distributions.R b/tests/testthat/tests.distributions.R index 31be25673..652b44bcc 100644 --- a/tests/testthat/tests.distributions.R +++ b/tests/testthat/tests.distributions.R @@ -229,6 +229,9 @@ test_that("hurdle distribution functions run without errors", { expect_true(length(res) == n) res <- phurdle_poisson(x, lambda = 1, hu = 0.1) expect_true(length(res) == n) + p <- rbeta(n, shape1 = 2, shape2 = 2) + res <- qhurdle_poisson(p, lambda = 1, hu = 0.1) + expect_true(length(res) == n) res <- dhurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) expect_true(length(res) == n) diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R index 87221de3c..623412e16 100644 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -40,6 +40,20 @@ test_that("qcom_poisson reduces to qpois when shape is 1", { ) }) +test_that("qhurdle_poisson satisfies the discrete quantile definition", { + lambda <- 2 + hu <- 0.2 + p <- c(0.01, 0.1, 0.5, 0.85, 0.99) + + q <- brms:::qhurdle_poisson(p, lambda = lambda, hu = hu) + F_q <- brms:::phurdle_poisson(q, lambda = lambda, hu = hu) + F_qm1 <- brms:::phurdle_poisson(q - 1, lambda = lambda, hu = hu) + + expect_true(all(F_q >= p)) + expect_true(all(ifelse(q > 0, F_qm1 < p, TRUE))) + expect_true(all(q >= 0)) +}) + test_that("qzero_inflated_negbinomial satisfies the discrete quantile definition", { mu <- 4 shape <- 2.5 From 20d246603351589ae8711c2360ffd397834f1e25 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 14:58:56 +0300 Subject: [PATCH 49/63] feat: update posterior_predict_hurdle_poisson --- R/posterior_predict.R | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index adec6fe67..626e32737 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -776,17 +776,25 @@ posterior_predict_cox <- function(i, prep, ...) { "distribution for family 'cox'.") } -posterior_predict_hurdle_poisson <- function(i, prep, ...) { - # hu is the bernoulli hurdle parameter +posterior_predict_hurdle_poisson <- function(i, prep, output = "random", + ntrys = 5, ...) { hu <- get_dpar(prep, "hu", i = i) lambda <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - # compare with hu to incorporate the hurdle process - tmp <- runif(ndraws, 0, 1) - # sample from a truncated poisson distribution - # by adjusting lambda and adding 1 - t <- -log(1 - runif(ndraws) * (1 - exp(-lambda))) - ifelse(tmp < hu, 0, rpois(ndraws, lambda = lambda - t) + 1) + lambda <- multiply_dpar_rate_denom(lambda, prep, i = i) + + if (output == "random") { + if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { + warning2( + "Truncated random sampling is not yet implemented for hurdle_poisson." + ) + } + qhurdle_poisson(runif(prep$ndraws), lambda = lambda, hu = hu) + } else { + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_poisson", lambda = lambda, hu = hu, ... + ) + } } posterior_predict_hurdle_negbinomial <- function(i, prep, ...) { From 557a640a3d3df1d9162db736101f18bc6fd98ee2 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 15:04:39 +0300 Subject: [PATCH 50/63] feat: add qhurdle_negbinomial and update posterior_predict_hurdle_negbinomial --- NAMESPACE | 1 + R/distributions.R | 8 ++++++++ R/posterior_predict.R | 24 +++++++++++++++++------- man/Hurdle.Rd | 3 +++ 4 files changed, 29 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 4a2f15809..8ff1f4061 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -563,6 +563,7 @@ export(qbeta_binomial) export(qexgaussian) export(qfrechet) export(qgen_extreme_value) +export(qhurdle_negbinomial) export(qhurdle_poisson) export(qinv_gaussian) export(qshifted_lnorm) diff --git a/R/distributions.R b/R/distributions.R index a26ade4db..01d7690bc 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2240,6 +2240,14 @@ phurdle_negbinomial <- function(q, mu, shape, hu, lower.tail = TRUE, .phurdle(q, "nbinom", hu, pars, lower.tail, log.p, type = "int") } +#' @rdname Hurdle +#' @export +qhurdle_negbinomial <- function(p, mu, shape, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(mu, size = shape) + .qhurdle(p, "nbinom", hu, pars, lower.tail, log.p, type = "int") +} + #' @rdname Hurdle #' @export dhurdle_gamma <- function(x, shape, scale, hu, log = FALSE) { diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 626e32737..82bd9ac47 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -797,16 +797,26 @@ posterior_predict_hurdle_poisson <- function(i, prep, output = "random", } } -posterior_predict_hurdle_negbinomial <- function(i, prep, ...) { +posterior_predict_hurdle_negbinomial <- function(i, prep, output = "random", + ntrys = 5, ...) { hu <- get_dpar(prep, "hu", i = i) mu <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - tmp <- runif(ndraws, 0, 1) - # sample from an approximate(!) truncated negbinomial distribution - # by adjusting mu and adding 1 - t <- -log(1 - runif(ndraws) * (1 - exp(-mu))) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- get_dpar(prep, "shape", i = i) - ifelse(tmp < hu, 0, rnbinom(ndraws, mu = mu - t, size = shape) + 1) + + if (output == "random") { + if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { + warning2( + "Truncated random sampling is not yet implemented for hurdle_negbinomial." + ) + } + qhurdle_negbinomial(runif(prep$ndraws), mu = mu, shape = shape, hu = hu) + } else { + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_negbinomial", mu = mu, shape = shape, hu = hu, ... + ) + } } posterior_predict_hurdle_gamma <- function(i, prep, ...) { diff --git a/man/Hurdle.Rd b/man/Hurdle.Rd index b1b35a28f..2f9a94a34 100644 --- a/man/Hurdle.Rd +++ b/man/Hurdle.Rd @@ -7,6 +7,7 @@ \alias{qhurdle_poisson} \alias{dhurdle_negbinomial} \alias{phurdle_negbinomial} +\alias{qhurdle_negbinomial} \alias{dhurdle_gamma} \alias{phurdle_gamma} \alias{dhurdle_lognormal} @@ -23,6 +24,8 @@ dhurdle_negbinomial(x, mu, shape, hu, log = FALSE) phurdle_negbinomial(q, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) +qhurdle_negbinomial(p, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) + dhurdle_gamma(x, shape, scale, hu, log = FALSE) phurdle_gamma(q, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) From 172ee9c0e1d2350673cecded85b57776cfb14ae2 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 15:15:38 +0300 Subject: [PATCH 51/63] feat: add qhurdle_gamma/_lognormal and update posterior_predict_hurdle_gamma/lognormal --- NAMESPACE | 2 ++ R/distributions.R | 16 ++++++++++++++++ R/posterior_predict.R | 40 ++++++++++++++++++++++++++++++++-------- man/Hurdle.Rd | 6 ++++++ 4 files changed, 56 insertions(+), 8 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8ff1f4061..7027af21f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -563,6 +563,8 @@ export(qbeta_binomial) export(qexgaussian) export(qfrechet) export(qgen_extreme_value) +export(qhurdle_gamma) +export(qhurdle_lognormal) export(qhurdle_negbinomial) export(qhurdle_poisson) export(qinv_gaussian) diff --git a/R/distributions.R b/R/distributions.R index 01d7690bc..2e09c0c35 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2263,6 +2263,14 @@ phurdle_gamma <- function(q, shape, scale, hu, lower.tail = TRUE, .phurdle(q, "gamma", hu, pars, lower.tail, log.p, type = "real") } +#' @rdname Hurdle +#' @export +qhurdle_gamma <- function(p, shape, scale, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(shape, scale) + .qhurdle(p, "gamma", hu, pars, lower.tail, log.p, type = "real") +} + #' @rdname Hurdle #' @export dhurdle_lognormal <- function(x, mu, sigma, hu, log = FALSE) { @@ -2278,6 +2286,14 @@ phurdle_lognormal <- function(q, mu, sigma, hu, lower.tail = TRUE, .phurdle(q, "lnorm", hu, pars, lower.tail, log.p, type = "real") } +#' @rdname Hurdle +#' @export +qhurdle_lognormal <- function(p, mu, sigma, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- list(meanlog = mu, sdlog = sigma) + .qhurdle(p, "lnorm", hu, pars, lower.tail, log.p, type = "real") +} + # density of a hurdle distribution # @param dist name of the distribution # @param hu bernoulli hurdle parameter diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 82bd9ac47..b74b9d6f9 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -819,22 +819,46 @@ posterior_predict_hurdle_negbinomial <- function(i, prep, output = "random", } } -posterior_predict_hurdle_gamma <- function(i, prep, ...) { +posterior_predict_hurdle_gamma <- function(i, prep, output = "random", + ntrys = 5, ...) { hu <- get_dpar(prep, "hu", i = i) shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / shape - ndraws <- prep$ndraws - tmp <- runif(ndraws, 0, 1) - ifelse(tmp < hu, 0, rgamma(ndraws, shape = shape, scale = scale)) + + if (output == "random") { + if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { + warning2( + "Truncated random sampling is not yet implemented for hurdle_gamma." + ) + } + qhurdle_gamma(runif(prep$ndraws), shape = shape, scale = scale, hu = hu) + } else { + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_gamma", shape = shape, scale = scale, hu = hu, ... + ) + } } -posterior_predict_hurdle_lognormal <- function(i, prep, ...) { +posterior_predict_hurdle_lognormal <- function(i, prep, output = "random", + ntrys = 5, ...) { hu <- get_dpar(prep, "hu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) - ndraws <- prep$ndraws - tmp <- runif(ndraws, 0, 1) - ifelse(tmp < hu, 0, rlnorm(ndraws, meanlog = mu, sdlog = sigma)) + + if (output == "random") { + if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { + warning2( + "Truncated random sampling is not yet implemented for hurdle_lognormal." + ) + } + qhurdle_lognormal(runif(prep$ndraws), mu = mu, sigma = sigma, hu = hu) + } else { + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_lognormal", mu = mu, sigma = sigma, hu = hu, ... + ) + } } posterior_predict_hurdle_cumulative <- function(i, prep, ...) { diff --git a/man/Hurdle.Rd b/man/Hurdle.Rd index 2f9a94a34..e60230c11 100644 --- a/man/Hurdle.Rd +++ b/man/Hurdle.Rd @@ -10,8 +10,10 @@ \alias{qhurdle_negbinomial} \alias{dhurdle_gamma} \alias{phurdle_gamma} +\alias{qhurdle_gamma} \alias{dhurdle_lognormal} \alias{phurdle_lognormal} +\alias{qhurdle_lognormal} \title{Hurdle Distributions} \usage{ dhurdle_poisson(x, lambda, hu, log = FALSE) @@ -30,9 +32,13 @@ dhurdle_gamma(x, shape, scale, hu, log = FALSE) phurdle_gamma(q, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) +qhurdle_gamma(p, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) + dhurdle_lognormal(x, mu, sigma, hu, log = FALSE) phurdle_lognormal(q, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) + +qhurdle_lognormal(p, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) } \arguments{ \item{x}{Vector of quantiles.} From 3ff3a38b2aff9df1ce387744eaa93a89f9716851 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Wed, 24 Jun 2026 15:24:26 +0300 Subject: [PATCH 52/63] docs: add tol argument to ExGaussian and InvGaussian --- R/distributions.R | 4 ++++ man/ExGaussian.Rd | 3 +++ man/InvGaussian.Rd | 3 +++ 3 files changed, 10 insertions(+) diff --git a/R/distributions.R b/R/distributions.R index 2e09c0c35..04e2e7c16 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -665,6 +665,8 @@ rvon_mises <- function(n, mu, kappa) { #' @param mu Vector of means of the combined distribution. #' @param sigma Vector of standard deviations of the gaussian component. #' @param beta Vector of scales of the exponential component. +#' @param tol Tolerance of the approximation used in the +#' quantile function. Default 1e-8. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. @@ -925,6 +927,8 @@ rshifted_lnorm <- function(n, meanlog = 0, sdlog = 1, shift = 0) { #' @param x,q Vector of quantiles. #' @param mu Vector of locations. #' @param shape Vector of shapes. +#' @param tol Tolerance of the approximation used in the +#' quantile function. Default 1e-8. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. diff --git a/man/ExGaussian.Rd b/man/ExGaussian.Rd index ecc55163a..f1a7ff17c 100644 --- a/man/ExGaussian.Rd +++ b/man/ExGaussian.Rd @@ -34,6 +34,9 @@ Else, return P(X > x) .} \item{p}{Vector of probabilities.} +\item{tol}{Tolerance of the approximation used in the +quantile function. Default 1e-8.} + \item{n}{Number of draws to sample from the distribution.} } \description{ diff --git a/man/InvGaussian.Rd b/man/InvGaussian.Rd index eba6086c6..551e66c21 100644 --- a/man/InvGaussian.Rd +++ b/man/InvGaussian.Rd @@ -39,6 +39,9 @@ Else, return P(X > x) .} \item{p}{Vector of probabilities.} +\item{tol}{Tolerance of the approximation used in the +quantile function. Default 1e-8.} + \item{n}{Number of draws to sample from the distribution.} } \description{ From c3cca08b040c132cbd956b0246f67cfa2a7f698e Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 09:08:57 +0300 Subject: [PATCH 53/63] feat: add qzero_inflated_asym_laplace and posterior_predict_zero_inflated_asym_laplace --- R/distributions.R | 38 +++++++++++++++++++ R/posterior_predict.R | 34 ++++++++++------- .../tests.distributions_quantile_outputs.R | 25 ++++++++++++ tests/testthat/tests.posterior_predict.R | 8 +++- 4 files changed, 91 insertions(+), 14 deletions(-) diff --git a/R/distributions.R b/R/distributions.R index 04e2e7c16..bf2d4601e 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2102,6 +2102,42 @@ pzero_inflated_asym_laplace <- function(q, mu, sigma, quantile, zi, type = "real", lb = -Inf, ub = Inf) } +# @rdname ZeroInflated +# @export +qzero_inflated_asym_laplace <- function(p, mu, sigma, quantile, zi, + lower.tail = TRUE, log.p = FALSE) { + # mixture: zi at 0 and (1 - zi) * asym_laplace on (-Inf, Inf) + # so the quantile is not a standard positive-support hurdle quantile + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- expand(dots = nlist(p, mu, sigma, quantile, zi)) + p <- args$p + mu <- args$mu + sigma <- args$sigma + quantile <- args$quantile + zi <- args$zi + F0_base <- pasym_laplace(0, mu = mu, sigma = sigma, quantile = quantile) + F0_minus <- (1 - zi) * F0_base + F0 <- zi + (1 - zi) * F0_base + out <- rep(0, length(p)) + idx_lo <- which(p < F0_minus & zi < 1) + idx_hi <- which(p > F0 & zi < 1) + if (length(idx_lo)) { + out[idx_lo] <- qasym_laplace( + p[idx_lo] / (1 - zi[idx_lo]), + mu = mu[idx_lo], sigma = sigma[idx_lo], quantile = quantile[idx_lo] + ) + } + if (length(idx_hi)) { + out[idx_hi] <- qasym_laplace( + (p[idx_hi] - zi[idx_hi]) / (1 - zi[idx_hi]), + mu = mu[idx_hi], sigma = sigma[idx_hi], quantile = quantile[idx_hi] + ) + } + out[!is.finite(p)] <- p[!is.finite(p)] + dim(out) <- attributes(args)$max_dim + out +} + # density of a zero-inflated distribution # @param dist name of the distribution # @param zi bernoulli zero-inflated parameter @@ -2400,6 +2436,8 @@ qhurdle_lognormal <- function(p, mu, sigma, hu, lower.tail = TRUE, p_dist <- ifelse(hu == 1, 0, p_dist) p_dist <- pmin(1, pmax(0, p_dist)) out <- do_call(qfun, c(list(p_dist), pars)) + # point mass at zero for p in [0, hu] + out[p <= hu] <- 0 out[!is.finite(p)] <- p[!is.finite(p)] dim(out) <- attributes(args)$max_dim out diff --git a/R/posterior_predict.R b/R/posterior_predict.R index b74b9d6f9..543f794eb 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -754,21 +754,29 @@ posterior_predict_asym_laplace <- function(i, prep, output = "random", ) } -posterior_predict_zero_inflated_asym_laplace <- function(i, prep, ntrys = 5, - ...) { +posterior_predict_zero_inflated_asym_laplace <- function(i, prep, + output = "random", + ntrys = 5, ...) { zi <- get_dpar(prep, "zi", i = i) - tmp <- runif(prep$ndraws, 0, 1) - ifelse( - tmp < zi, 0, - rcontinuous( - n = prep$ndraws, dist = "asym_laplace", - mu = get_dpar(prep, "mu", i = i), - sigma = get_dpar(prep, "sigma", i = i), - quantile = get_dpar(prep, "quantile", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + quantile <- get_dpar(prep, "quantile", i = i) + + if (output == "random") { + out <- predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "asym_laplace", mu = mu, sigma = sigma, quantile = quantile, ... ) - ) + tmp <- runif(prep$ndraws, 0, 1) + out <- ifelse(tmp < zi, 0, out) + } else { + out <- predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "zero_inflated_asym_laplace", + mu = mu, sigma = sigma, quantile = quantile, zi = zi, ... + ) + } + out } posterior_predict_cox <- function(i, prep, ...) { diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R index 623412e16..7a30c863a 100644 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -69,6 +69,31 @@ test_that("qzero_inflated_negbinomial satisfies the discrete quantile definition expect_true(all(q >= 0)) }) +test_that("qzero_inflated_asym_laplace matches the mixture CDF", { + mu <- 0 + sigma <- 1 + quantile <- 0.5 + zi <- 0.3 + p <- c(0.01, 0.1, 0.3, 0.5, 0.65, 0.85, 0.99) + + q <- brms:::qzero_inflated_asym_laplace( + p, mu = mu, sigma = sigma, quantile = quantile, zi = zi + ) + F0_base <- brms:::pasym_laplace(0, mu = mu, sigma = sigma, quantile = quantile) + F0_minus <- (1 - zi) * F0_base + F0 <- zi + (1 - zi) * F0_base + + expect_true(all(q[p < F0_minus] < 0)) + expect_equal(q[p >= F0_minus & p <= F0], rep(0, sum(p >= F0_minus & p <= F0))) + expect_true(all(q[p > F0] > 0)) + expect_true(all(diff(q) >= 0)) + + F_q <- brms:::pzero_inflated_asym_laplace( + q, mu = mu, sigma = sigma, quantile = quantile, zi = zi + ) + expect_true(all(F_q + 1e-8 >= p)) +}) + test_that("quantile functions are monotone in probability", { p <- seq(0.01, 0.99, length.out = 50) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 9330d20cd..3fd22e04d 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -487,7 +487,8 @@ make_prep_positive_outcome <- function(ns = 120, nobs = 8) { xi = rnorm(ns, sd = 0.3), quantile = runif(ns, min = 0.2, max = 0.8), phi = rgamma(ns, shape = 5, rate = 1), - kappa = rgamma(ns, shape = 2, rate = 1) + kappa = rgamma(ns, shape = 2, rate = 1), + zi = rbeta(ns, 1.5, 5) ), data = list(Y = rgamma(nobs, shape = 2, rate = 1)) ) @@ -623,6 +624,11 @@ test_that("posterior_predict outcome argument works for continuous families", { fun = brms:::posterior_predict_asym_laplace, q_ref = 0.25, p_ref = 0.73, support = c(-Inf, Inf), prep = make_prep_positive_outcome() ), + zero_inflated_asym_laplace = list( + fun = brms:::posterior_predict_zero_inflated_asym_laplace, + q_ref = 0.25, p_ref = 0.73, + support = c(-Inf, Inf), prep = make_prep_positive_outcome() + ), xbeta = list( fun = brms:::posterior_predict_xbeta, q_ref = 0.4, p_ref = 0.73, support = c(0, 1), prep = make_prep_beta_outcome(), requires = "betareg" From 05203406d324ab5a792551ca3e0803b36470196a Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 09:14:03 +0300 Subject: [PATCH 54/63] feat: add qzero_one_inflated_beta and posterior_predict_zero_one_inflated_beta --- NAMESPACE | 3 + R/distributions.R | 103 ++++++++++++++++++ R/posterior_predict.R | 32 ++++-- man/ZeroOneInflated.Rd | 60 ++++++++++ .../tests.distributions_quantile_outputs.R | 23 ++++ 5 files changed, 212 insertions(+), 9 deletions(-) create mode 100644 man/ZeroOneInflated.Rd diff --git a/NAMESPACE b/NAMESPACE index 7027af21f..ec4eaa746 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -426,6 +426,7 @@ export(dzero_inflated_beta_binomial) export(dzero_inflated_binomial) export(dzero_inflated_negbinomial) export(dzero_inflated_poisson) +export(dzero_one_inflated_beta) export(empty_prior) export(exgaussian) export(exponential) @@ -558,6 +559,7 @@ export(pzero_inflated_beta_binomial) export(pzero_inflated_binomial) export(pzero_inflated_negbinomial) export(pzero_inflated_poisson) +export(pzero_one_inflated_beta) export(qasym_laplace) export(qbeta_binomial) export(qexgaussian) @@ -577,6 +579,7 @@ export(qzero_inflated_beta_binomial) export(qzero_inflated_binomial) export(qzero_inflated_negbinomial) export(qzero_inflated_poisson) +export(qzero_one_inflated_beta) export(ranef) export(rasym_laplace) export(rbeta_binomial) diff --git a/R/distributions.R b/R/distributions.R index bf2d4601e..9e9d139cc 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2138,6 +2138,109 @@ qzero_inflated_asym_laplace <- function(p, mu, sigma, quantile, zi, out } +#' Zero-One-Inflated Beta Distribution +#' +#' Density, distribution function and quantile function for the +#' zero-one-inflated beta distribution. +#' +#' @name ZeroOneInflated +#' +#' @inheritParams StudentT +#' @param shape1,shape2 shape parameters of the beta component +#' @param zoi zero-one-inflation probability +#' @param coi conditional one-inflation probability +#' +#' @details +#' With probability \eqn{\zeta}{zoi} the response is 0 or 1, and conditionally +#' on inflation it is 1 with probability \eqn{\gamma}{coi}. With probability +#' \eqn{1 - \zeta}{1 - zoi} the response follows a beta distribution. +NULL + +#' @rdname ZeroOneInflated +#' @export +dzero_one_inflated_beta <- function(x, shape1, shape2, zoi, coi, log = FALSE) { + log <- as_one_logical(log) + args <- expand(dots = nlist(x, shape1, shape2, zoi, coi)) + x <- args$x + shape1 <- args$shape1 + shape2 <- args$shape2 + zoi <- args$zoi + coi <- args$coi + out <- ifelse( + x == 0, + dbinom(1, size = 1, prob = zoi, log = TRUE) + + dbinom(0, size = 1, prob = coi, log = TRUE), + ifelse( + x == 1, + dbinom(1, size = 1, prob = zoi, log = TRUE) + + dbinom(1, size = 1, prob = coi, log = TRUE), + dbinom(0, size = 1, prob = zoi, log = TRUE) + + dbeta(x, shape1 = shape1, shape2 = shape2, log = TRUE) + ) + ) + out[x < 0 | x > 1] <- -Inf + if (!log) { + out <- exp(out) + } + dim(out) <- attributes(args)$max_dim + out +} + +#' @rdname ZeroOneInflated +#' @export +pzero_one_inflated_beta <- function(q, shape1, shape2, zoi, coi, + lower.tail = TRUE, log.p = FALSE) { + lower.tail <- as_one_logical(lower.tail) + log.p <- as_one_logical(log.p) + args <- expand(dots = nlist(q, shape1, shape2, zoi, coi)) + q <- args$q + shape1 <- args$shape1 + shape2 <- args$shape2 + zoi <- args$zoi + coi <- args$coi + # F(q) = zoi * (1 - coi) + (1 - zoi) * F_beta(q) for q in [0, 1) + # and F(q) = 1 for q >= 1 + out <- zoi * (1 - coi) + (1 - zoi) * pbeta(q, shape1 = shape1, shape2 = shape2) + out[q < 0] <- 0 + out[q >= 1] <- 1 + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + dim(out) <- attributes(args)$max_dim + out +} + +#' @rdname ZeroOneInflated +#' @export +qzero_one_inflated_beta <- function(p, shape1, shape2, zoi, coi, + lower.tail = TRUE, log.p = FALSE) { + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + args <- expand(dots = nlist(p, shape1, shape2, zoi, coi)) + p <- args$p + shape1 <- args$shape1 + shape2 <- args$shape2 + zoi <- args$zoi + coi <- args$coi + p0 <- zoi * (1 - coi) + p1 <- zoi * coi + out <- rep(0, length(p)) + idx_mid <- which(p > p0 & p < (1 - p1) & zoi < 1) + idx_one <- which(p >= (1 - p1)) + if (length(idx_mid)) { + out[idx_mid] <- qbeta( + (p[idx_mid] - p0[idx_mid]) / (1 - zoi[idx_mid]), + shape1 = shape1[idx_mid], shape2 = shape2[idx_mid] + ) + } + out[idx_one] <- 1 + out[!is.finite(p)] <- p[!is.finite(p)] + dim(out) <- attributes(args)$max_dim + out +} + # density of a zero-inflated distribution # @param dist name of the distribution # @param zi bernoulli zero-inflated parameter diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 543f794eb..d46f2ef79 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -915,17 +915,31 @@ posterior_predict_zero_inflated_beta <- function(i, prep, output = "random", out } -posterior_predict_zero_one_inflated_beta <- function(i, prep, ...) { - zoi <- get_dpar(prep, "zoi", i) - coi <- get_dpar(prep, "coi", i) +posterior_predict_zero_one_inflated_beta <- function(i, prep, output = "random", + ntrys = 5, ...) { + zoi <- get_dpar(prep, "zoi", i = i) + coi <- get_dpar(prep, "coi", i = i) mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) - tmp <- runif(prep$ndraws, 0, 1) - one_or_zero <- runif(prep$ndraws, 0, 1) - ifelse(tmp < zoi, - ifelse(one_or_zero < coi, 1, 0), - rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) - ) + shape1 <- mu * phi + shape2 <- (1 - mu) * phi + + if (output == "random") { + tmp <- runif(prep$ndraws, 0, 1) + one_or_zero <- runif(prep$ndraws, 0, 1) + out <- ifelse( + tmp < zoi, + ifelse(one_or_zero < coi, 1, 0), + rbeta(prep$ndraws, shape1 = shape1, shape2 = shape2) + ) + } else { + out <- predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "zero_one_inflated_beta", + shape1 = shape1, shape2 = shape2, zoi = zoi, coi = coi, ... + ) + } + out } posterior_predict_zero_inflated_poisson <- function(i, prep, output = "random", diff --git a/man/ZeroOneInflated.Rd b/man/ZeroOneInflated.Rd new file mode 100644 index 000000000..5368c8dfd --- /dev/null +++ b/man/ZeroOneInflated.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{ZeroOneInflated} +\alias{ZeroOneInflated} +\alias{dzero_one_inflated_beta} +\alias{pzero_one_inflated_beta} +\alias{qzero_one_inflated_beta} +\title{Zero-One-Inflated Beta Distribution} +\usage{ +dzero_one_inflated_beta(x, shape1, shape2, zoi, coi, log = FALSE) + +pzero_one_inflated_beta( + q, + shape1, + shape2, + zoi, + coi, + lower.tail = TRUE, + log.p = FALSE +) + +qzero_one_inflated_beta( + p, + shape1, + shape2, + zoi, + coi, + lower.tail = TRUE, + log.p = FALSE +) +} +\arguments{ +\item{x}{Vector of quantiles.} + +\item{shape1, shape2}{shape parameters of the beta component} + +\item{zoi}{zero-one-inflation probability} + +\item{coi}{conditional one-inflation probability} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{q}{Vector of quantiles.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{p}{Vector of probabilities.} +} +\description{ +Density, distribution function and quantile function for the +zero-one-inflated beta distribution. +} +\details{ +With probability \eqn{\zeta}{zoi} the response is 0 or 1, and conditionally +on inflation it is 1 with probability \eqn{\gamma}{coi}. With probability +\eqn{1 - \zeta}{1 - zoi} the response follows a beta distribution. +} diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R index 7a30c863a..52bdff973 100644 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -69,6 +69,29 @@ test_that("qzero_inflated_negbinomial satisfies the discrete quantile definition expect_true(all(q >= 0)) }) +test_that("qzero_one_inflated_beta matches the mixture CDF", { + shape1 <- 2 + shape2 <- 3 + zoi <- 0.25 + coi <- 0.4 + p <- c(0.01, 0.1, 0.2, 0.5, 0.9, 0.95, 0.99) + p0 <- zoi * (1 - coi) + p1 <- zoi * coi + + q <- brms:::qzero_one_inflated_beta( + p, shape1 = shape1, shape2 = shape2, zoi = zoi, coi = coi + ) + expect_equal(q[p <= p0], rep(0, sum(p <= p0))) + expect_equal(q[p >= 1 - p1], rep(1, sum(p >= 1 - p1))) + expect_true(all(q[p > p0 & p < 1 - p1] > 0 & q[p > p0 & p < 1 - p1] < 1)) + expect_true(all(diff(q) >= 0)) + + F_q <- brms:::pzero_one_inflated_beta( + q, shape1 = shape1, shape2 = shape2, zoi = zoi, coi = coi + ) + expect_true(all(F_q + 1e-8 >= p)) +}) + test_that("qzero_inflated_asym_laplace matches the mixture CDF", { mu <- 0 sigma <- 1 From 1002ee89c9fb6af9b8d82b5dd3a94e904b0d0e3b Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 09:58:19 +0300 Subject: [PATCH 55/63] feat: add d/q/rordinal and posterior_predict_ordinal --- R/distributions.R | 95 ++++++++++++++++++- R/posterior_predict.R | 27 +++--- .../tests.distributions_quantile_outputs.R | 29 ++++++ tests/testthat/tests.posterior_predict.R | 35 +++++++ 4 files changed, 169 insertions(+), 17 deletions(-) diff --git a/R/distributions.R b/R/distributions.R index 9e9d139cc..098a8d489 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -3019,6 +3019,33 @@ link_acat <- function(x, link) { out } +# density for ordinal distributions +# @param x positive integers not greater than ncat +# @param eta draws of the linear predictor +# @param thres draws of threshold parameters +# @param disc draws of the discrimination parameter +# @param family a character string naming the family +# @param link a character string naming the link +# @param log return values on the log scale? +# @return a vector (if length(x) == 1) or matrix of probabilities P(X = x) +dordinal <- function(x, eta, thres, disc = 1, family = NULL, link = "logit", + log = FALSE) { + family <- as_one_character(family) + link <- as_one_character(link) + log <- as_one_logical(log) + out <- do_call( + paste0("d", family), + nlist(x, eta, thres, disc, link) + ) + if (length(x) == 1L) { + out <- as.vector(out) + } + if (log) { + out <- log(out) + } + out +} + # CDF for ordinal distributions # @param q positive integers not greater than ncat # @param eta draws of the linear predictor @@ -3026,14 +3053,72 @@ link_acat <- function(x, link) { # @param disc draws of the discrimination parameter # @param family a character string naming the family # @param link a character string naming the link -# @return a matrix of probabilities P(x <= q) +# @return a vector (if length(q) == 1) or matrix of probabilities P(x <= q) pordinal <- function(q, eta, thres, disc = 1, family = NULL, link = "logit") { family <- as_one_character(family) link <- as_one_character(link) - args <- nlist(x = seq_len(max(q)), eta, thres, disc, link) - p <- do_call(paste0("d", family), args) - .fun <- function(j) rowSums(as.matrix(p[, 1:j, drop = FALSE])) - cblapply(q, .fun) + ncat <- NCOL(thres) + 1L + ndraws <- if (!is.null(dim(eta))) NROW(eta) else length(eta) + q_max <- max(q) + if (q_max > 0) { + args <- nlist(x = seq_len(min(q_max, ncat)), eta, thres, disc, link) + p <- do_call(paste0("d", family), args) + } else { + p <- matrix(0, nrow = ndraws, ncol = 0) + } + .fun <- function(j) { + if (j <= 0) { + return(rep(0, ndraws)) + } + if (j >= ncat) { + return(rep(1, ndraws)) + } + rowSums(as.matrix(p[, 1:j, drop = FALSE])) + } + out <- cblapply(q, .fun) + if (length(q) == 1L) { + out <- as.vector(out) + } + out +} + +# quantile function for ordinal distributions +# @param p vector of probabilities +# @param eta draws of the linear predictor +# @param thres draws of threshold parameters +# @param disc draws of the discrimination parameter +# @param family a character string naming the family +# @param link a character string naming the link +# @return a vector of category indices +qordinal <- function(p, eta, thres, disc = 1, family = NULL, link = "logit", + lower.tail = TRUE, log.p = FALSE) { + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + ncat <- NCOL(thres) + 1L + F_all <- pordinal( + seq_len(ncat), eta = eta, thres = thres, disc = disc, + family = family, link = link + ) + ndraws <- NROW(F_all) + if (length(p) == 1L) { + p <- rep(p, ndraws) + } + first_greater(F_all, target = p) +} + +# random generation for ordinal distributions +# @param n number of observations +# @param eta draws of the linear predictor +# @param thres draws of threshold parameters +# @param disc draws of the discrimination parameter +# @param family a character string naming the family +# @param link a character string naming the link +# @return a vector of category indices +rordinal <- function(n, eta, thres, disc = 1, family = NULL, link = "logit") { + n <- check_n_rdist(n, eta, disc) + qordinal( + runif(n), eta = eta, thres = thres, disc = disc, + family = family, link = link + ) } # helper functions to shift arbitrary distributions diff --git a/R/posterior_predict.R b/R/posterior_predict.R index d46f2ef79..f5c5157f2 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1080,33 +1080,36 @@ posterior_predict_logistic_normal <- function(i, prep, ...) { } posterior_predict_cumulative <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) + posterior_predict_ordinal(i = i, prep = prep, ...) } posterior_predict_sratio <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) + posterior_predict_ordinal(i = i, prep = prep, ...) } posterior_predict_cratio <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) + posterior_predict_ordinal(i = i, prep = prep, ...) } posterior_predict_acat <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) + posterior_predict_ordinal(i = i, prep = prep, ...) } -posterior_predict_ordinal <- function(i, prep, ...) { +posterior_predict_ordinal <- function(i, prep, output = "random", ...) { thres <- subset_thres(prep, i) - nthres <- NCOL(thres) - p <- pordinal( - seq_len(nthres + 1), - eta = get_dpar(prep, "mu", i = i), - disc = get_dpar(prep, "disc", i = i), + eta <- get_dpar(prep, "mu", i = i) + disc <- get_dpar(prep, "disc", i = i) + + predict_discrete_helper( + i = i, prep = prep, output = output, + dist = "ordinal", + eta = eta, + disc = disc, thres = thres, family = prep$family$family, - link = prep$family$link + link = prep$family$link, + ... ) - first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) } posterior_predict_custom <- function(i, prep, ...) { diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R index 52bdff973..e5f91b461 100644 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -69,6 +69,35 @@ test_that("qzero_inflated_negbinomial satisfies the discrete quantile definition expect_true(all(q >= 0)) }) +test_that("qordinal matches the ordinal CDF", { + set.seed(11) + ns <- 7 + nthres <- 3 + eta <- rnorm(ns) + thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) + disc <- rep(1, ns) + p <- c(0.05, 0.25, 0.5, 0.75, 0.95) + + for (fam in c("cumulative", "sratio", "cratio", "acat")) { + F_mat <- brms:::pordinal( + seq_len(nthres + 1), eta = eta, thres = thres, disc = disc, + family = fam, link = "logit" + ) + for (pj in p) { + qj <- brms:::qordinal( + pj, eta = eta, thres = thres, disc = disc, + family = fam, link = "logit" + ) + expect_length(qj, ns) + expect_true(all(qj >= 1 & qj <= nthres + 1)) + expect_true(all(F_mat[cbind(seq_len(ns), qj)] + 1e-10 >= pj)) + expect_true(all( + ifelse(qj > 1, F_mat[cbind(seq_len(ns), qj - 1)] < pj + 1e-10, TRUE) + )) + } + } +}) + test_that("qzero_one_inflated_beta matches the mixture CDF", { shape1 <- 2 shape2 <- 3 diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 3fd22e04d..c07a99b8a 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -708,6 +708,41 @@ test_that("posterior_predict outcome argument works for discrete families", { } }) +test_that("posterior_predict output argument works for ordinal families", { + ns <- 80 + nobs <- 6 + nthres <- 3 + ncat <- nthres + 1 + set.seed(1010) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + disc = rexp(ns) + ) + prep$thres$thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) + prep$data <- list( + Y = rep(1:ncat, length.out = nobs), + ncat = ncat, + lb = rep(NULL, nobs), + ub = rep(NULL, nobs) + ) + prep$family$link <- "logit" + i <- 2 + + for (fam in c("cumulative", "sratio", "cratio", "acat")) { + prep$family$family <- fam + expect_outcome_modes( + family_fun = brms:::posterior_predict_ordinal, + prep = prep, + i = i, + q_ref = 2, + p_ref = 0.7, + support = c(1, ncat), + check_integer = TRUE + ) + } +}) + test_that("compute_cdf returns correct CDF for non-truncated distributions", { # Non-truncated, non-randomized: raw CDF F(q) q <- 3 From b70152ebcd0f41101551c6425b7e755a97742835 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 10:05:42 +0300 Subject: [PATCH 56/63] feat: add p/q/rcategorical and posterior_predict_categorical --- R/distributions.R | 63 ++++++++++++++++++- R/posterior_predict.R | 10 ++- .../tests.distributions_quantile_outputs.R | 19 ++++++ tests/testthat/tests.posterior_predict.R | 31 +++++++++ 4 files changed, 118 insertions(+), 5 deletions(-) diff --git a/R/distributions.R b/R/distributions.R index 098a8d489..82382bdfa 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2626,15 +2626,74 @@ link_categorical <- function(x, refcat = 1, return_refcat = FALSE) { # @param q positive integers not greater than ncat # @param eta the linear predictor (of length or ncol ncat) # @param log.p return values on the log scale? +# @return a vector (if length(q) == 1) or matrix of probabilities P(X <= q) pcategorical <- function(q, eta, log.p = FALSE) { - p <- dcategorical(seq_len(max(q)), eta = eta) - out <- cblapply(q, function(j) rowSums(p[, 1:j, drop = FALSE])) + if (is.null(dim(eta))) { + eta <- matrix(eta, nrow = 1) + } + if (length(dim(eta)) != 2L) { + stop2("eta must be a numeric vector or matrix.") + } + ncat <- NCOL(eta) + ndraws <- NROW(eta) + q_max <- max(q) + if (q_max > 0) { + p <- dcategorical(seq_len(min(q_max, ncat)), eta = eta) + } else { + p <- matrix(0, nrow = ndraws, ncol = 0) + } + .fun <- function(j) { + if (j <= 0) { + return(rep(0, ndraws)) + } + if (j >= ncat) { + return(rep(1, ndraws)) + } + rowSums(as.matrix(p[, 1:j, drop = FALSE])) + } + out <- cblapply(q, .fun) if (log.p) { out <- log(out) } + if (length(q) == 1L) { + out <- as.vector(out) + } out } +# quantile function of the categorical distribution +# @param p vector of probabilities +# @param eta the linear predictor (of length or ncol ncat) +# @return a vector of category indices +qcategorical <- function(p, eta, lower.tail = TRUE, log.p = FALSE) { + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + if (is.null(dim(eta))) { + eta <- matrix(eta, nrow = 1) + } + ncat <- NCOL(eta) + F_all <- pcategorical(seq_len(ncat), eta = eta) + ndraws <- NROW(F_all) + if (length(p) == 1L) { + p <- rep(p, ndraws) + } + first_greater(F_all, target = p) +} + +# random generation for the categorical distribution +# @param n number of observations +# @param eta the linear predictor (of length or ncol ncat) +# @return a vector of category indices +rcategorical <- function(n, eta) { + if (is.null(dim(eta))) { + eta <- matrix(eta, nrow = 1) + } + n <- as.integer(as_one_numeric(n)) + if (!n %in% c(1L, NROW(eta))) { + stop2("'n' must match the number of rows of 'eta'.") + } + qcategorical(runif(NROW(eta)), eta = eta) +} + # density of the multinomial distribution with the softmax transform # @param x positive integers not greater than ncat # @param eta the linear predictor (of length or ncol ncat) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index f5c5157f2..8b1a2541b 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -1030,11 +1030,15 @@ posterior_predict_zero_inflated_beta_binomial <- function(i, prep, out } -posterior_predict_categorical <- function(i, prep, ...) { +posterior_predict_categorical <- function(i, prep, output = "random", ...) { eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) - p <- pcategorical(seq_len(prep$data$ncat), eta = eta) - first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) + predict_discrete_helper( + i = i, prep = prep, output = output, + dist = "categorical", + eta = eta, + ... + ) } posterior_predict_multinomial <- function(i, prep, ...) { diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R index e5f91b461..877d42711 100644 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -98,6 +98,25 @@ test_that("qordinal matches the ordinal CDF", { } }) +test_that("qcategorical matches the categorical CDF", { + set.seed(12) + ns <- 7 + ncat <- 4 + eta <- matrix(rnorm(ns * ncat), nrow = ns) + p <- c(0.05, 0.25, 0.5, 0.75, 0.95) + F_mat <- brms:::pcategorical(seq_len(ncat), eta = eta) + + for (pj in p) { + qj <- brms:::qcategorical(pj, eta = eta) + expect_length(qj, ns) + expect_true(all(qj >= 1 & qj <= ncat)) + expect_true(all(F_mat[cbind(seq_len(ns), qj)] + 1e-10 >= pj)) + expect_true(all( + ifelse(qj > 1, F_mat[cbind(seq_len(ns), qj - 1)] < pj + 1e-10, TRUE) + )) + } +}) + test_that("qzero_one_inflated_beta matches the mixture CDF", { shape1 <- 2 shape2 <- 3 diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index c07a99b8a..89654daa9 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -743,6 +743,37 @@ test_that("posterior_predict output argument works for ordinal families", { } }) +test_that("posterior_predict output argument works for categorical", { + set.seed(1011) + ns <- 80 + nobs <- 6 + ncat <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu1 = matrix(rnorm(ns * nobs, 0, 0.1), ncol = nobs), + mu2 = matrix(rnorm(ns * nobs, 0, 0.1), ncol = nobs) + ) + prep$data <- list( + Y = rep(1:ncat, length.out = nobs), + ncat = ncat, + lb = rep(NULL, nobs), + ub = rep(NULL, nobs) + ) + prep$family <- categorical() + prep$refcat <- 1 + i <- 2 + + expect_outcome_modes( + family_fun = brms:::posterior_predict_categorical, + prep = prep, + i = i, + q_ref = 2, + p_ref = 0.7, + support = c(1, ncat), + check_integer = TRUE + ) +}) + test_that("compute_cdf returns correct CDF for non-truncated distributions", { # Non-truncated, non-randomized: raw CDF F(q) q <- 3 From c9a29cb16c9117d9b0c538023f8746e90fca9e97 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 10:09:59 +0300 Subject: [PATCH 57/63] feat: add p/q/rhurdle_cumulative and posterior_predict_hurdle_cumulative --- R/distributions.R | 106 ++++++++++++++++++ R/posterior_predict.R | 30 ++--- .../tests.distributions_quantile_outputs.R | 33 ++++++ tests/testthat/tests.posterior_predict.R | 33 ++++++ 4 files changed, 183 insertions(+), 19 deletions(-) diff --git a/R/distributions.R b/R/distributions.R index 82382bdfa..d0c49ae77 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2437,6 +2437,112 @@ qhurdle_lognormal <- function(p, mu, sigma, hu, lower.tail = TRUE, .qhurdle(p, "lnorm", hu, pars, lower.tail, log.p, type = "real") } +# density of the hurdle-cumulative distribution +# categories: 0 = hurdle, 1..ncat = cumulative ordinal categories +# @param x category indices +# @param eta draws of the linear predictor +# @param thres draws of threshold parameters +# @param hu hurdle probability +# @param disc discrimination parameter +# @param link link function of the ordinal part +# @param log return values on the log scale? +dhurdle_cumulative <- function(x, eta, thres, hu, disc = 1, link = "logit", + log = FALSE) { + log <- as_one_logical(log) + link <- as_one_character(link) + ncat <- NCOL(thres) + 1L + ndraws <- if (!is.null(dim(eta))) NROW(eta) else length(eta) + if (length(hu) == 1L) { + hu <- rep(hu, ndraws) + } + out <- matrix(0, nrow = ndraws, ncol = length(x)) + for (j in seq_along(x)) { + xj <- x[j] + if (xj == 0) { + out[, j] <- hu + } else if (xj >= 1 && xj <= ncat) { + out[, j] <- (1 - hu) * as.vector( + dcumulative(xj, eta = eta, thres = thres, disc = disc, link = link) + ) + } + } + if (length(x) == 1L) { + out <- as.vector(out) + } + if (log) { + out <- log(out) + } + out +} + +# CDF of the hurdle-cumulative distribution +# @return a vector (if length(q) == 1) or matrix of probabilities P(X <= q) +phurdle_cumulative <- function(q, eta, thres, hu, disc = 1, link = "logit") { + link <- as_one_character(link) + ncat <- NCOL(thres) + 1L + ndraws <- if (!is.null(dim(eta))) NROW(eta) else length(eta) + if (length(hu) == 1L) { + hu <- rep(hu, ndraws) + } + .fun <- function(j) { + if (j < 0) { + return(rep(0, ndraws)) + } + if (j == 0) { + return(hu) + } + if (j >= ncat) { + return(rep(1, ndraws)) + } + F_ord <- pordinal( + j, eta = eta, thres = thres, disc = disc, + family = "cumulative", link = link + ) + hu + (1 - hu) * F_ord + } + out <- cblapply(q, .fun) + if (length(q) == 1L) { + out <- as.vector(out) + } + out +} + +# quantile function of the hurdle-cumulative distribution +qhurdle_cumulative <- function(p, eta, thres, hu, disc = 1, link = "logit", + lower.tail = TRUE, log.p = FALSE) { + p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) + link <- as_one_character(link) + ndraws <- if (!is.null(dim(eta))) NROW(eta) else length(eta) + if (length(hu) == 1L) { + hu <- rep(hu, ndraws) + } + if (length(p) == 1L) { + p <- rep(p, ndraws) + } + if (length(disc) == 1L) { + disc <- rep(disc, ndraws) + } + out <- rep(0L, ndraws) + idx <- which(p > hu & hu < 1) + if (length(idx)) { + out[idx] <- qordinal( + (p[idx] - hu[idx]) / (1 - hu[idx]), + eta = eta[idx], thres = thres[idx, , drop = FALSE], disc = disc[idx], + family = "cumulative", link = link + ) + } + out[!is.finite(p)] <- p[!is.finite(p)] + out +} + +# random generation for the hurdle-cumulative distribution +rhurdle_cumulative <- function(n, eta, thres, hu, disc = 1, link = "logit") { + n <- check_n_rdist(n, eta, hu, disc) + qhurdle_cumulative( + runif(n), eta = eta, thres = thres, hu = hu, disc = disc, link = link + ) +} + # density of a hurdle distribution # @param dist name of the distribution # @param hu bernoulli hurdle parameter diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 8b1a2541b..3853dc547 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -869,25 +869,17 @@ posterior_predict_hurdle_lognormal <- function(i, prep, output = "random", } } -posterior_predict_hurdle_cumulative <- function(i, prep, ...) { - mu <- get_dpar(prep, "mu", i = i) - hu <- get_dpar(prep, "hu", i = i) - disc <- get_dpar(prep, "disc", i = i) - thres <- subset_thres(prep) - nthres <- NCOL(thres) - ndraws <- prep$ndraws - p <- pordinal( - seq_len(nthres + 1L), - eta = mu, - disc = disc, - thres = thres, - family = "cumulative", - link = prep$family$link - ) - tmp <- runif(ndraws, 0, 1) - ifelse( - tmp < hu, 0L, - first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) +posterior_predict_hurdle_cumulative <- function(i, prep, output = "random", + ...) { + predict_discrete_helper( + i = i, prep = prep, output = output, + dist = "hurdle_cumulative", + eta = get_dpar(prep, "mu", i = i), + disc = get_dpar(prep, "disc", i = i), + hu = get_dpar(prep, "hu", i = i), + thres = subset_thres(prep, i), + link = prep$family$link, + ... ) } diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R index 877d42711..11f56d20f 100644 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ b/tests/testthat/tests.distributions_quantile_outputs.R @@ -117,6 +117,39 @@ test_that("qcategorical matches the categorical CDF", { } }) +test_that("qhurdle_cumulative matches the mixture CDF", { + set.seed(13) + ns <- 7 + nthres <- 3 + ncat <- nthres + 1 + eta <- rnorm(ns) + thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) + disc <- rep(1, ns) + hu <- rep(0.25, ns) + p <- c(0.05, 0.2, 0.25, 0.5, 0.9, 0.99) + + for (pj in p) { + qj <- brms:::qhurdle_cumulative( + pj, eta = eta, thres = thres, hu = hu, disc = disc, link = "logit" + ) + expect_length(qj, ns) + expect_true(all(qj >= 0 & qj <= ncat)) + F_q <- vapply(seq_len(ns), function(s) { + brms:::phurdle_cumulative( + qj[s], eta = eta[s], thres = thres[s, , drop = FALSE], + hu = hu[s], disc = disc[s], link = "logit" + ) + }, numeric(1)) + expect_true(all(F_q + 1e-10 >= pj)) + } + expect_equal( + brms:::qhurdle_cumulative( + 0.1, eta = eta, thres = thres, hu = hu, disc = disc, link = "logit" + ), + rep(0, ns) + ) +}) + test_that("qzero_one_inflated_beta matches the mixture CDF", { shape1 <- 2 shape2 <- 3 diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index 89654daa9..bc11fa04a 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -774,6 +774,39 @@ test_that("posterior_predict output argument works for categorical", { ) }) +test_that("posterior_predict output argument works for hurdle_cumulative", { + set.seed(1012) + ns <- 80 + nobs <- 6 + nthres <- 3 + ncat <- nthres + 1 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + disc = rexp(ns), + hu = rbeta(ns, 1.5, 5) + ) + prep$thres$thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) + prep$data <- list( + Y = rep(0:ncat, length.out = nobs), + ncat = ncat, + lb = rep(NULL, nobs), + ub = rep(NULL, nobs) + ) + prep$family <- hurdle_cumulative() + i <- 2 + + expect_outcome_modes( + family_fun = brms:::posterior_predict_hurdle_cumulative, + prep = prep, + i = i, + q_ref = 2, + p_ref = 0.7, + support = c(0, ncat), + check_integer = TRUE + ) +}) + test_that("compute_cdf returns correct CDF for non-truncated distributions", { # Non-truncated, non-randomized: raw CDF F(q) q <- 3 From 6d9d4c513f0452ea01cdcf8b060319b89659f775 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 13:06:49 +0300 Subject: [PATCH 58/63] refactor: same API for all function but error when output != 'random' is not implemented --- R/posterior_predict.R | 129 ++++++++++++++++++++++++++++++++---------- 1 file changed, 99 insertions(+), 30 deletions(-) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 3853dc547..07c63838b 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -30,6 +30,8 @@ #' \code{"probability"}, \code{"pit"}, \code{"density"}, or #' \code{"quantile"}. Defaults to \code{"random"}. In case of continuous #' distributions, \code{"probability"} is equivalent to \code{"pit"}. +#' Not all families support outputs other than \code{"random"} yet; +#' requesting an unsupported combination raises an error. #' @param q Custom quantile for computing probability, PIT, or density values. #' It defaults to NULL in which case \code{prep$data$Y[i]} is used. #' @param p Custom probability for computing quantile values. @@ -138,6 +140,7 @@ posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, output <- rlang::arg_match( output, values = c("random", "probability", "pit", "density", "quantile") ) + validate_pp_output_support(object$family$fun, output) summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) @@ -391,7 +394,8 @@ posterior_predict_skew_normal <- function(i, prep, output = "random", ) } -posterior_predict_gaussian_mv <- function(i, prep, ...) { +posterior_predict_gaussian_mv <- function(i, prep, output = "random", ...) { + validate_pp_output_support("gaussian_mv", output) Mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i) .predict <- function(s) { @@ -400,7 +404,8 @@ posterior_predict_gaussian_mv <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_student_mv <- function(i, prep, ...) { +posterior_predict_student_mv <- function(i, prep, output = "random", ...) { + validate_pp_output_support("student_mv", output) nu <- get_dpar(prep, "nu", i = i) Mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i) @@ -410,7 +415,8 @@ posterior_predict_student_mv <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_gaussian_time <- function(i, prep, ...) { +posterior_predict_gaussian_time <- function(i, prep, output = "random", ...) { + validate_pp_output_support("gaussian_time", output) obs <- with(prep$ac, begin_tg[i]:end_tg[i]) Jtime <- prep$ac$Jtime_tg[i, ] mu <- as.matrix(get_dpar(prep, "mu", i = obs)) @@ -421,7 +427,8 @@ posterior_predict_gaussian_time <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_student_time <- function(i, prep, ...) { +posterior_predict_student_time <- function(i, prep, output = "random", ...) { + validate_pp_output_support("student_time", output) obs <- with(prep$ac, begin_tg[i]:end_tg[i]) Jtime <- prep$ac$Jtime_tg[i, ] nu <- as.matrix(get_dpar(prep, "nu", i = obs)) @@ -433,7 +440,8 @@ posterior_predict_student_time <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_gaussian_lagsar <- function(i, prep, ...) { +posterior_predict_gaussian_lagsar <- function(i, prep, output = "random", ...) { + validate_pp_output_support("gaussian_lagsar", output) stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) @@ -446,7 +454,8 @@ posterior_predict_gaussian_lagsar <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_student_lagsar <- function(i, prep, ...) { +posterior_predict_student_lagsar <- function(i, prep, output = "random", ...) { + validate_pp_output_support("student_lagsar", output) stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) @@ -460,7 +469,9 @@ posterior_predict_student_lagsar <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_gaussian_errorsar <- function(i, prep, ...) { +posterior_predict_gaussian_errorsar <- function(i, prep, output = "random", + ...) { + validate_pp_output_support("gaussian_errorsar", output) stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) @@ -472,7 +483,9 @@ posterior_predict_gaussian_errorsar <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_student_errorsar <- function(i, prep, ...) { +posterior_predict_student_errorsar <- function(i, prep, output = "random", + ...) { + validate_pp_output_support("student_errorsar", output) stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) @@ -485,7 +498,8 @@ posterior_predict_student_errorsar <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_gaussian_fcor <- function(i, prep, ...) { +posterior_predict_gaussian_fcor <- function(i, prep, output = "random", ...) { + validate_pp_output_support("gaussian_fcor", output) stopifnot(i == 1) mu <- as.matrix(get_dpar(prep, "mu")) Sigma <- get_cov_matrix_ac(prep) @@ -495,7 +509,8 @@ posterior_predict_gaussian_fcor <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_student_fcor <- function(i, prep, ...) { +posterior_predict_student_fcor <- function(i, prep, output = "random", ...) { + validate_pp_output_support("student_fcor", output) stopifnot(i == 1) nu <- as.matrix(get_dpar(prep, "nu")) mu <- as.matrix(get_dpar(prep, "mu")) @@ -691,8 +706,9 @@ posterior_predict_exgaussian <- function(i, prep, output = "random", ntrys = 5, ) } -posterior_predict_wiener <- function(i, prep, negative_rt = FALSE, ntrys = 5, - ...) { +posterior_predict_wiener <- function(i, prep, output = "random", + negative_rt = FALSE, ntrys = 5, ...) { + validate_pp_output_support("wiener", output) out <- rcontinuous( n = 1, dist = "wiener", delta = get_dpar(prep, "mu", i = i), @@ -779,7 +795,7 @@ posterior_predict_zero_inflated_asym_laplace <- function(i, prep, out } -posterior_predict_cox <- function(i, prep, ...) { +posterior_predict_cox <- function(i, prep, output = "random", ...) { stop2("Cannot sample from the posterior predictive ", "distribution for family 'cox'.") } @@ -1033,7 +1049,8 @@ posterior_predict_categorical <- function(i, prep, output = "random", ...) { ) } -posterior_predict_multinomial <- function(i, prep, ...) { +posterior_predict_multinomial <- function(i, prep, output = "random", ...) { + validate_pp_output_support("multinomial", output) eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) p <- dcategorical(seq_len(prep$data$ncat), eta = eta) @@ -1041,7 +1058,9 @@ posterior_predict_multinomial <- function(i, prep, ...) { rblapply(seq_rows(p), function(s) t(rmultinom(1, size, p[s, ]))) } -posterior_predict_dirichlet_multinomial <- function(i, prep, ...) { +posterior_predict_dirichlet_multinomial <- function(i, prep, output = "random", + ...) { + validate_pp_output_support("dirichlet_multinomial", output) eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) phi <- get_dpar(prep, "phi", i = i) @@ -1051,7 +1070,8 @@ posterior_predict_dirichlet_multinomial <- function(i, prep, ...) { rblapply(seq_rows(p), function(s) t(rmultinom(1, size, p[s, ]))) } -posterior_predict_dirichlet <- function(i, prep, ...) { +posterior_predict_dirichlet <- function(i, prep, output = "random", ...) { + validate_pp_output_support("dirichlet", output) eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) phi <- get_dpar(prep, "phi", i = i) @@ -1060,12 +1080,14 @@ posterior_predict_dirichlet <- function(i, prep, ...) { rdirichlet(prep$ndraws, alpha = alpha) } -posterior_predict_dirichlet2 <- function(i, prep, ...) { +posterior_predict_dirichlet2 <- function(i, prep, output = "random", ...) { + validate_pp_output_support("dirichlet2", output) mu <- get_Mu(prep, i = i) rdirichlet(prep$ndraws, alpha = mu) } -posterior_predict_logistic_normal <- function(i, prep, ...) { +posterior_predict_logistic_normal <- function(i, prep, output = "random", ...) { + validate_pp_output_support("logistic_normal", output) mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i, cor_name = "lncor") .predict <- function(s) { @@ -1075,20 +1097,20 @@ posterior_predict_logistic_normal <- function(i, prep, ...) { rblapply(seq_len(prep$ndraws), .predict) } -posterior_predict_cumulative <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep, ...) +posterior_predict_cumulative <- function(i, prep, output = "random", ...) { + posterior_predict_ordinal(i = i, prep = prep, output = output, ...) } -posterior_predict_sratio <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep, ...) +posterior_predict_sratio <- function(i, prep, output = "random", ...) { + posterior_predict_ordinal(i = i, prep = prep, output = output, ...) } -posterior_predict_cratio <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep, ...) +posterior_predict_cratio <- function(i, prep, output = "random", ...) { + posterior_predict_ordinal(i = i, prep = prep, output = output, ...) } -posterior_predict_acat <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep, ...) +posterior_predict_acat <- function(i, prep, output = "random", ...) { + posterior_predict_ordinal(i = i, prep = prep, output = output, ...) } posterior_predict_ordinal <- function(i, prep, output = "random", ...) { @@ -1108,11 +1130,25 @@ posterior_predict_ordinal <- function(i, prep, output = "random", ...) { ) } -posterior_predict_custom <- function(i, prep, ...) { - custom_family_method(prep$family, "posterior_predict")(i, prep, ...) +posterior_predict_custom <- function(i, prep, output = "random", ...) { + fun <- custom_family_method(prep$family, "posterior_predict") + args <- names(formals(fun)) + if ("output" %in% args || "..." %in% args) { + fun(i, prep, output = output, ...) + } else { + # older custom methods may not accept output yet + if (!identical(output, "random")) { + stop2( + "Output '", output, "' is not yet implemented for this custom family. ", + "Only output = 'random' is currently supported." + ) + } + fun(i, prep, ...) + } } -posterior_predict_mixture <- function(i, prep, ...) { +posterior_predict_mixture <- function(i, prep, output = "random", ...) { + validate_pp_output_support("mixture", output) families <- family_names(prep$family) theta <- get_theta(prep, i = i) smix <- sample_mixture_ids(theta) @@ -1123,13 +1159,46 @@ posterior_predict_mixture <- function(i, prep, ...) { pp_fun <- paste0("posterior_predict_", families[j]) pp_fun <- get(pp_fun, asNamespace("brms")) tmp_prep <- pseudo_prep_for_mixture(prep, j, draw_ids) - out[draw_ids] <- pp_fun(i, tmp_prep, ...) + out[draw_ids] <- pp_fun(i, tmp_prep, output = output, ...) } } out } # ------------ predict helper-functions ---------------------- + +# families that currently only support output = "random" +# (multivariate, time-series, compositional, and diffusion models) +pp_output_random_only_families <- c( + "gaussian_mv", "student_mv", + "gaussian_time", "student_time", + "gaussian_lagsar", "student_lagsar", + "gaussian_errorsar", "student_errorsar", + "gaussian_fcor", "student_fcor", + "wiener", + "multinomial", "dirichlet_multinomial", + "dirichlet", "dirichlet2", "logistic_normal", + "mixture" +) + +# error if a non-random output is requested for an unsupported family +# @param family_fun name of the family method suffix (object$family$fun) +# @param output validated output type +# @noRd +validate_pp_output_support <- function(family_fun, output) { + if (output == "random") { + return(invisible(NULL)) + } + family_fun <- as_one_character(family_fun) + if (family_fun %in% pp_output_random_only_families) { + stop2( + "Output '", output, "' is not yet implemented for family '", + family_fun, "'. Only output = 'random' is currently supported." + ) + } + invisible(NULL) +} + # random numbers from (possibly truncated) continuous distributions # @param n number of random values to generate # @param distribution name of a distribution for which the functions From d27f9d0d385783f10eed6ab4b2f595f7c08ead1b Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 14:20:44 +0300 Subject: [PATCH 59/63] tests: add and clean tests for posterior_predict and distributions --- tests/testthat/helper-distributions.R | 1750 +++++++++++++++++ tests/testthat/helper-posterior-predict.R | 331 ++++ .../testthat/tests.distributions_analytical.R | 271 +++ .../tests.distributions_quantile_outputs.R | 255 --- .../testthat/tests.distributions_relations.R | 60 + tests/testthat/tests.posterior_predict.R | 473 +---- 6 files changed, 2498 insertions(+), 642 deletions(-) create mode 100644 tests/testthat/helper-distributions.R create mode 100644 tests/testthat/helper-posterior-predict.R create mode 100644 tests/testthat/tests.distributions_analytical.R delete mode 100644 tests/testthat/tests.distributions_quantile_outputs.R create mode 100644 tests/testthat/tests.distributions_relations.R diff --git a/tests/testthat/helper-distributions.R b/tests/testthat/helper-distributions.R new file mode 100644 index 000000000..201d2e985 --- /dev/null +++ b/tests/testthat/helper-distributions.R @@ -0,0 +1,1750 @@ +# Distribution registry, prep fixtures, and d/p/q/r expectations. +# posterior_predict expectations live in helper-posterior-predict.R +# (sourced after this file alphabetically). +# +# How to add a family +# ------------------- +# 1. Register an entry with `dist_registry_add()` (or append in +# `dist_registry_populate()`). Required fields: +# name, backend, type, d/p/q/r (NULL if missing), params, support, +# pp_fun, prep_builder, outputs, flags +# 2. Map `backend` to the name used by predict_*_helper / compute_* +# (e.g. gaussian -> "norm", poisson -> "pois"). +# 3. Set `type` to continuous|discrete|mixture|ordinal|circular. +# 4. List supported `outputs`: random|probability|pit|density|quantile. +# 5. Flags (logical list), common ones: +# truncation - exercise truncated CDF/PDF/quantile +# numeric_q - quantile solved numerically +# no_random_truncation- random sampling ignores truncation (warns) +# zi / hurdle - mixture formulas vs a baseline d/p +# skip_integrate - skip integrate-to-one (e.g. circular, heavy tails) +# skip_moments - skip moment checks +# skip_rng_cdf - skip RNG-vs-CDF KS-style checks +# stub - registry placeholder without deep d/p/q checks +# 6. Implement `prep_builder()` returning a minimal +# `structure(list(...), class = "brmsprep")` fixture. +# Prefer constant dpars so PP vs d/p/q comparisons are exact. +# entry$params MUST match args PP passes to the backend. +# 7. Prefer consolidating analytical / special cases into +# tests.distributions_analytical.R. +# +# Families are registered when this helper is sourced via dist_registry_populate(). + +# --------------------------------------------------------------------------- +# Registry infrastructure +# --------------------------------------------------------------------------- + +.dist_registry_env <- new.env(parent = emptyenv()) +.dist_registry_env$entries <- list() + +#' Create a family registry entry +#' @noRd +dist_entry <- function( + name, + backend, + type = c("continuous", "discrete", "mixture", "ordinal", "circular"), + d = NULL, + p = NULL, + q = NULL, + r = NULL, + params = list(), + support = c(-Inf, Inf), + ref = NULL, + pp_fun = NULL, + prep_builder = NULL, + outputs = c("random", "probability", "pit", "density", "quantile"), + flags = list(), + q_ref = NULL, + p_ref = 0.7, + baseline = NULL +) { + type <- match.arg(type) + flags_default <- list( + truncation = TRUE, + numeric_q = FALSE, + no_random_truncation = FALSE, + zi = FALSE, + hurdle = FALSE, + skip_integrate = FALSE, + skip_moments = FALSE, + skip_rng_cdf = FALSE, + skip_pdf_fd = FALSE, + skip_p_tail_flags = FALSE, + skip_d_sums = FALSE, + pq_elementwise = FALSE, + has_atoms = FALSE, + stub = FALSE, + discrete_support = type %in% c("discrete", "ordinal") + ) + flags <- utils::modifyList(flags_default, flags) + if (is.null(q_ref)) { + q_ref <- if (flags$discrete_support) { + max(0, ceiling(mean(support[is.finite(support)]))) + } else { + 0 + } + } + list( + name = name, + backend = backend, + type = type, + d = d, + p = p, + q = q, + r = r, + params = params, + support = support, + ref = ref, + pp_fun = pp_fun, + prep_builder = prep_builder, + outputs = outputs, + flags = flags, + q_ref = q_ref, + p_ref = p_ref, + baseline = baseline + ) +} + +dist_registry_clear <- function() { + .dist_registry_env$entries <- list() + invisible(.dist_registry_env$entries) +} + +dist_registry_add <- function(entry) { + stopifnot(is.list(entry), !is.null(entry$name)) + .dist_registry_env$entries[[entry$name]] <- entry + invisible(entry) +} + +dist_registry_get <- function(name = NULL, type = NULL, flag = NULL) { + entries <- .dist_registry_env$entries + if (!is.null(name)) { + entries <- entries[intersect(name, names(entries))] + } + if (!is.null(type)) { + entries <- Filter(function(e) e$type %in% type, entries) + } + if (!is.null(flag)) { + entries <- Filter(function(e) isTRUE(e$flags[[flag]]), entries) + } + entries +} + +dist_registry_names <- function(...) { + names(dist_registry_get(...)) +} + +has_output <- function(entry, output) { + output %in% entry$outputs +} + +has_fun <- function(entry, which = c("d", "p", "q", "r", "pp_fun")) { + which <- match.arg(which) + !is.null(entry[[which]]) +} + +entry_requires <- function(entry) { + req <- entry$ref$requires + if (is.null(req)) character() else req +} + +entry_deps_available <- function(entry) { + req <- entry_requires(entry) + if (!length(req)) return(TRUE) + all(vapply(req, requireNamespace, logical(1), quietly = TRUE)) +} + +# Non-stub registry entries with dependencies available. +# Additional filters: type (passed to dist_registry_get), require_funs (d/p/q/r/pp_fun), +# truncation / discrete_support (match flags), has_baseline (non-NULL baseline). +dist_active_entries <- function( + type = NULL, + require_funs = NULL, + truncation = NULL, + discrete_support = NULL, + has_baseline = NULL +) { + Filter(function(e) { + if (isTRUE(e$flags$stub)) return(FALSE) + if (!entry_deps_available(e)) return(FALSE) + if (!is.null(require_funs)) { + ok_funs <- vapply(require_funs, function(f) has_fun(e, f), logical(1)) + if (!all(ok_funs)) return(FALSE) + } + if (!is.null(truncation) && !identical(isTRUE(e$flags$truncation), truncation)) { + return(FALSE) + } + if (!is.null(discrete_support) && + !identical(isTRUE(e$flags$discrete_support), discrete_support)) { + return(FALSE) + } + if (!is.null(has_baseline) && !identical(!is.null(e$baseline), has_baseline)) { + return(FALSE) + } + TRUE + }, dist_registry_get(type = type)) +} + +call_dist <- function(fun, x, params, ...) { + do.call(fun, c(list(x), params, list(...))) +} + +# --------------------------------------------------------------------------- +# Prep builders (minimal brmsprep fixtures) +# --------------------------------------------------------------------------- + +.empty_bounds <- function(nobs) { + list(lb = rep(NULL, nobs), ub = rep(NULL, nobs)) +} + +make_prep_location <- function(ns = 25, nobs = 4, mu = 0, sigma = 1, + extra = list(), Y = NULL, seed = NULL) { + if (!is.null(seed)) withr::local_seed(seed) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- c( + list( + mu = matrix(mu, nrow = ns, ncol = nobs), + sigma = rep(sigma, ns) + ), + extra + ) + if (is.null(Y)) Y <- rep(mu, nobs) + prep$data <- c(list(Y = Y), .empty_bounds(nobs)) + prep +} + +make_prep_positive <- function(ns = 25, nobs = 4, mu = 1, shape = 2, + extra = list(), Y = NULL, seed = NULL) { + if (!is.null(seed)) withr::local_seed(seed) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- c( + list( + mu = matrix(mu, nrow = ns, ncol = nobs), + shape = rep(shape, ns), + sigma = rep(1, ns), + beta = rep(1, ns) + ), + extra + ) + if (is.null(Y)) Y <- rep(mu, nobs) + prep$data <- c(list(Y = Y), .empty_bounds(nobs)) + prep +} + +make_prep_count <- function(ns = 25, nobs = 4, mu = 3, shape = 2, + trials = 10, zi = 0.2, hu = 0.2, + extra = list(), Y = NULL, seed = NULL) { + if (!is.null(seed)) withr::local_seed(seed) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- c( + list( + mu = matrix(mu, nrow = ns, ncol = nobs), + shape = rep(shape, ns), + phi = rep(5, ns), + zi = rep(zi, ns), + hu = rep(hu, ns) + ), + extra + ) + if (is.null(Y)) Y <- rep(as.integer(mu), nobs) + prep$data <- c( + list(Y = Y, trials = rep(trials, nobs)), + .empty_bounds(nobs) + ) + prep +} + +make_prep_beta_mix <- function(ns = 25, nobs = 4, mu = 0.4, phi = 5, + zoi = 0.2, coi = 0.4, Y = NULL, seed = NULL) { + if (!is.null(seed)) withr::local_seed(seed) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(mu, nrow = ns, ncol = nobs), + phi = rep(phi, ns), + zoi = rep(zoi, ns), + coi = rep(coi, ns) + ) + if (is.null(Y)) Y <- rep(mu, nobs) + prep$data <- c(list(Y = Y), .empty_bounds(nobs)) + prep +} + +make_prep_ordinal <- function(ns = 25, nobs = 4, nthres = 3, + family = "cumulative", link = "logit", + hu = NULL, Y = NULL, seed = NULL) { + if (!is.null(seed)) withr::local_seed(seed) + ncat <- nthres + 1L + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(0, nrow = ns, ncol = nobs), + disc = rep(1, ns) + ) + if (!is.null(hu)) { + prep$dpars$hu <- rep(hu, ns) + } + prep$thres$thres <- matrix(rep(c(-1, 0, 1)[seq_len(nthres)], each = ns), + nrow = ns) + if (is.null(Y)) { + Y <- if (is.null(hu)) { + rep(seq_len(ncat), length.out = nobs) + } else { + rep(0:ncat, length.out = nobs) + } + } + prep$data <- c(list(Y = Y, ncat = ncat), .empty_bounds(nobs)) + prep$family$family <- family + prep$family$link <- link + prep +} + +make_prep_categorical <- function(ns = 25, nobs = 4, ncat = 3, + Y = NULL, seed = NULL) { + if (!is.null(seed)) withr::local_seed(seed) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + # reference category inserted by posterior_predict_categorical + mu_names <- paste0("mu", seq_len(ncat - 1L)) + prep$dpars <- setNames( + lapply(mu_names, function(nm) matrix(0, nrow = ns, ncol = nobs)), + mu_names + ) + if (is.null(Y)) Y <- rep(seq_len(ncat), length.out = nobs) + prep$data <- c(list(Y = Y, ncat = ncat), .empty_bounds(nobs)) + prep$family <- categorical() + prep$refcat <- 1L + prep +} + +set_trunc_bounds <- function(prep, lb = NULL, ub = NULL, i = NULL) { + nobs <- prep$nobs + if (is.null(i)) i <- seq_len(nobs) + # Match existing fixtures: numeric vectors when truncating; indexing + # with prep$data$lb[i] must return a scalar (see predict_*_helper). + if (!is.null(lb)) { + lb_vec <- rep(lb, nobs) + prep$data$lb <- lb_vec + } + if (!is.null(ub)) { + ub_vec <- rep(ub, nobs) + prep$data$ub <- ub_vec + } + prep +} + +# --------------------------------------------------------------------------- +# Registry population +# --------------------------------------------------------------------------- + +dist_registry_populate <- function(reset = TRUE) { + if (reset) dist_registry_clear() + + dist_registry_add(dist_entry( + name = "gaussian", + backend = "norm", + type = "continuous", + d = stats::dnorm, + p = stats::pnorm, + q = stats::qnorm, + r = stats::rnorm, + params = list(mean = 0, sd = 1), + support = c(-Inf, Inf), + ref = list(d = stats::dnorm, p = stats::pnorm, q = stats::qnorm), + pp_fun = brms:::posterior_predict_gaussian, + prep_builder = function(...) make_prep_location(mu = 0, sigma = 1, ...), + q_ref = 0.25, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "student_t", + backend = "student_t", + type = "continuous", + d = dstudent_t, + p = pstudent_t, + q = qstudent_t, + r = rstudent_t, + params = list(df = 7, mu = 0, sigma = 1), + support = c(-Inf, Inf), + pp_fun = brms:::posterior_predict_student, + prep_builder = function(ns = 25, ...) { + make_prep_location( + ns = ns, mu = 0, sigma = 1, + extra = list(nu = rep(7, ns)), + ... + ) + }, + q_ref = 0.25, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "inv_gaussian", + backend = "inv_gaussian", + type = "continuous", + d = dinv_gaussian, + p = pinv_gaussian, + q = qinv_gaussian, + r = rinv_gaussian, + params = list(mu = 1, shape = 2), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_inverse.gaussian, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_positive( + ns = ns, nobs = nobs, mu = 1, shape = 2, + Y = rep(1, nobs), ... + ) + }, + q_ref = 1.2, + flags = list(truncation = TRUE, numeric_q = TRUE) + )) + + dist_registry_add(dist_entry( + name = "exgaussian", + backend = "exgaussian", + type = "continuous", + d = dexgaussian, + p = pexgaussian, + q = qexgaussian, + r = rexgaussian, + params = list(mu = 0, sigma = 1, beta = 1), + support = c(-Inf, Inf), + pp_fun = brms:::posterior_predict_exgaussian, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_positive( + ns = ns, nobs = nobs, mu = 0, shape = 1, + extra = list(beta = rep(1, ns), sigma = rep(1, ns)), + Y = rep(0, nobs), + ... + ) + }, + q_ref = 0.5, + flags = list(truncation = TRUE, numeric_q = TRUE) + )) + + dist_registry_add(dist_entry( + name = "von_mises", + backend = "von_mises", + type = "circular", + d = dvon_mises, + p = pvon_mises, + q = qvon_mises, + r = rvon_mises, + params = list(mu = 0, kappa = 2), + support = c(-pi, pi), + pp_fun = brms:::posterior_predict_von_mises, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_location( + ns = ns, nobs = nobs, mu = 0, sigma = 1, + extra = list(kappa = rep(2, ns)), + Y = rep(0, nobs), + ... + ) + }, + q_ref = 0.2, + flags = list( + truncation = FALSE, + numeric_q = TRUE, + skip_integrate = FALSE, + skip_moments = TRUE, + skip_pdf_fd = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "pois", + backend = "pois", + type = "discrete", + d = stats::dpois, + p = stats::ppois, + q = stats::qpois, + r = stats::rpois, + params = list(lambda = 3), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_poisson, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count(ns = ns, nobs = nobs, mu = 3, Y = rep(3L, nobs), ...) + }, + q_ref = 3, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "binom", + backend = "binom", + type = "discrete", + d = stats::dbinom, + p = stats::pbinom, + q = stats::qbinom, + r = stats::rbinom, + params = list(size = 10, prob = 0.4), + support = c(0, 10), + pp_fun = brms:::posterior_predict_binomial, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 0.4, trials = 10, + Y = rep(4L, nobs), ... + ) + }, + q_ref = 4, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "beta_binomial", + backend = "beta_binomial", + type = "discrete", + d = brms:::dbeta_binomial, + p = brms:::pbeta_binomial, + q = brms:::qbeta_binomial, + r = brms:::rbeta_binomial, + params = list(size = 12, mu = 0.35, phi = 8), + support = c(0, 12), + pp_fun = brms:::posterior_predict_beta_binomial, + prep_builder = function(ns = 25, nobs = 4, ...) { + p <- make_prep_count( + ns = ns, nobs = nobs, mu = 0.35, trials = 12, + Y = rep(4L, nobs), ... + ) + p$dpars$phi <- rep(8, p$ndraws) + p + }, + q_ref = 4, + flags = list(truncation = TRUE), + # beta_binomial d/p/q/r require extraDistr + ref = list(requires = "extraDistr") + )) + + dist_registry_add(dist_entry( + name = "nbinom", + backend = "nbinom", + type = "discrete", + d = stats::dnbinom, + p = stats::pnbinom, + q = stats::qnbinom, + r = stats::rnbinom, + params = list(mu = 4, size = 2.5), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_negbinomial, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 4, shape = 2.5, + Y = rep(4L, nobs), ... + ) + }, + q_ref = 3, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "com_poisson", + backend = "com_poisson", + type = "discrete", + d = brms:::dcom_poisson, + p = brms:::pcom_poisson, + q = brms:::qcom_poisson, + r = brms:::rcom_poisson, + params = list(mu = 2, shape = 0.8), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_com_poisson, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 2, shape = 0.8, + Y = rep(2L, nobs), ... + ) + }, + q_ref = 2, + flags = list( + truncation = TRUE, + skip_moments = TRUE, + skip_rng_cdf = TRUE, + skip_d_sums = TRUE, + pq_elementwise = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "hurdle_poisson", + backend = "hurdle_poisson", + type = "discrete", + d = brms:::dhurdle_poisson, + p = brms:::phurdle_poisson, + q = brms:::qhurdle_poisson, + r = NULL, + params = list(lambda = 2, hu = 0.2), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_hurdle_poisson, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 2, hu = 0.2, + Y = rep(2L, nobs), ... + ) + }, + q_ref = 2, + baseline = list( + d = stats::dpois, + p = stats::ppois, + params = list(lambda = 2), + mix = "hu" + ), + flags = list( + truncation = TRUE, + hurdle = TRUE, + no_random_truncation = TRUE, + skip_moments = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "zero_inflated_negbinomial", + backend = "zero_inflated_negbinomial", + type = "discrete", + d = brms:::dzero_inflated_negbinomial, + p = brms:::pzero_inflated_negbinomial, + q = brms:::qzero_inflated_negbinomial, + r = NULL, + params = list(mu = 4, shape = 2.5, zi = 0.3), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_zero_inflated_negbinomial, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 4, shape = 2.5, zi = 0.3, + Y = rep(3L, nobs), ... + ) + }, + q_ref = 3, + baseline = list( + d = stats::dnbinom, + p = stats::pnbinom, + params = list(mu = 4, size = 2.5), + mix = "zi" + ), + flags = list( + truncation = TRUE, + zi = TRUE, + skip_moments = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "zero_one_inflated_beta", + backend = "zero_one_inflated_beta", + type = "mixture", + d = brms:::dzero_one_inflated_beta, + p = brms:::pzero_one_inflated_beta, + q = brms:::qzero_one_inflated_beta, + r = NULL, + params = list(shape1 = 2, shape2 = 3, zoi = 0.25, coi = 0.4), + support = c(0, 1), + pp_fun = brms:::posterior_predict_zero_one_inflated_beta, + prep_builder = function(...) { + # mu * phi = shape1, (1-mu)*phi = shape2 => mu=2/5, phi=5 + make_prep_beta_mix(mu = 0.4, phi = 5, zoi = 0.25, coi = 0.4, ...) + }, + q_ref = 0.4, + flags = list( + truncation = FALSE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + has_atoms = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "zero_inflated_asym_laplace", + backend = "zero_inflated_asym_laplace", + type = "mixture", + d = brms:::dzero_inflated_asym_laplace, + p = brms:::pzero_inflated_asym_laplace, + q = brms:::qzero_inflated_asym_laplace, + r = NULL, + params = list(mu = 0, sigma = 1, quantile = 0.5, zi = 0.3), + support = c(-Inf, Inf), + pp_fun = brms:::posterior_predict_zero_inflated_asym_laplace, + prep_builder = function(ns = 25, ...) { + make_prep_location( + ns = ns, mu = 0, sigma = 1, + extra = list( + quantile = rep(0.5, ns), + zi = rep(0.3, ns) + ), + ... + ) + }, + q_ref = 0.25, + flags = list( + truncation = FALSE, + zi = TRUE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + has_atoms = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "ordinal_cumulative", + backend = "ordinal", + type = "ordinal", + d = function(x, ...) { + brms:::dordinal(x, family = "cumulative", link = "logit", ...) + }, + p = function(q, ...) { + brms:::pordinal(q, family = "cumulative", link = "logit", ...) + }, + q = function(p, ...) { + brms:::qordinal(p, family = "cumulative", link = "logit", ...) + }, + r = function(n, ...) { + brms:::rordinal(n, family = "cumulative", link = "logit", ...) + }, + params = list( + eta = 0, + thres = matrix(c(-1, 0, 1), nrow = 1), + disc = 1 + ), + support = c(1, 4), + pp_fun = brms:::posterior_predict_ordinal, + prep_builder = function(...) { + make_prep_ordinal(family = "cumulative", ...) + }, + q_ref = 2, + flags = list( + truncation = FALSE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + skip_rng_cdf = TRUE, + skip_p_tail_flags = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "categorical", + backend = "categorical", + type = "ordinal", + d = brms:::dcategorical, + p = brms:::pcategorical, + q = brms:::qcategorical, + r = brms:::rcategorical, + params = list(eta = matrix(c(0, 0, 0), nrow = 1)), + support = c(1, 3), + pp_fun = brms:::posterior_predict_categorical, + prep_builder = function(...) make_prep_categorical(ncat = 3, ...), + q_ref = 2, + flags = list( + truncation = FALSE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + skip_rng_cdf = TRUE, + skip_p_tail_flags = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "hurdle_cumulative", + backend = "hurdle_cumulative", + type = "ordinal", + d = function(x, ...) brms:::dhurdle_cumulative(x, link = "logit", ...), + p = function(q, ...) brms:::phurdle_cumulative(q, link = "logit", ...), + q = function(p, ...) brms:::qhurdle_cumulative(p, link = "logit", ...), + r = function(n, ...) brms:::rhurdle_cumulative(n, link = "logit", ...), + params = list( + eta = 0, + thres = matrix(c(-1, 0, 1), nrow = 1), + hu = 0.25, + disc = 1 + ), + support = c(0, 4), + pp_fun = brms:::posterior_predict_hurdle_cumulative, + prep_builder = function(...) { + make_prep_ordinal(family = "hurdle_cumulative", hu = 0.25, ...) + }, + q_ref = 2, + flags = list( + truncation = FALSE, + hurdle = TRUE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + skip_rng_cdf = TRUE, + skip_p_tail_flags = TRUE + ) + )) + + # ---- Continuous / positive ---- + + dist_registry_add(dist_entry( + name = "lognormal", + backend = "lnorm", + type = "continuous", + d = stats::dlnorm, + p = stats::plnorm, + q = stats::qlnorm, + r = stats::rlnorm, + params = list(meanlog = 0, sdlog = 1), + support = c(0, Inf), + ref = list(d = stats::dlnorm, p = stats::plnorm, q = stats::qlnorm), + pp_fun = brms:::posterior_predict_lognormal, + prep_builder = function(...) make_prep_location(mu = 0, sigma = 1, ...), + q_ref = 1, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "shifted_lognormal", + backend = "shifted_lnorm", + type = "continuous", + d = dshifted_lnorm, + p = pshifted_lnorm, + q = qshifted_lnorm, + r = rshifted_lnorm, + params = list(meanlog = 0, sdlog = 1, shift = 0.3), + support = c(0.3, Inf), + pp_fun = brms:::posterior_predict_shifted_lognormal, + prep_builder = function(ns = 25, ...) { + make_prep_location( + ns = ns, mu = 0, sigma = 1, + extra = list(ndt = rep(0.3, ns)), + ... + ) + }, + q_ref = 1.3, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "skew_normal", + backend = "skew_normal", + type = "continuous", + d = dskew_normal, + p = pskew_normal, + q = qskew_normal, + r = rskew_normal, + params = list(mu = 0, sigma = 1, alpha = 2), + support = c(-Inf, Inf), + ref = list(requires = "mnormt"), + pp_fun = brms:::posterior_predict_skew_normal, + prep_builder = function(ns = 25, ...) { + make_prep_location( + ns = ns, mu = 0, sigma = 1, + extra = list(alpha = rep(2, ns)), + ... + ) + }, + q_ref = 0.5, + flags = list( + truncation = TRUE, + skip_pdf_fd = TRUE, + skip_moments = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "exponential", + backend = "exp", + type = "continuous", + d = stats::dexp, + p = stats::pexp, + q = stats::qexp, + r = stats::rexp, + params = list(rate = 1), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_exponential, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_positive(ns = ns, nobs = nobs, mu = 1, Y = rep(1, nobs), ...) + }, + q_ref = 0.7, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "gamma", + backend = "gamma", + type = "continuous", + d = stats::dgamma, + p = stats::pgamma, + q = stats::qgamma, + r = stats::rgamma, + params = list(shape = 2, scale = 1), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_gamma, + prep_builder = function(ns = 25, nobs = 4, ...) { + # PP: scale = mu / shape => mu = shape * scale = 2 + make_prep_positive( + ns = ns, nobs = nobs, mu = 2, shape = 2, + Y = rep(2, nobs), ... + ) + }, + q_ref = 1.5, + flags = list(truncation = TRUE) + )) + + weibull_shape <- 2 + weibull_scale <- 1 + weibull_mu <- weibull_scale * gamma(1 + 1 / weibull_shape) + dist_registry_add(dist_entry( + name = "weibull", + backend = "weibull", + type = "continuous", + d = stats::dweibull, + p = stats::pweibull, + q = stats::qweibull, + r = stats::rweibull, + params = list(shape = weibull_shape, scale = weibull_scale), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_weibull, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_positive( + ns = ns, nobs = nobs, mu = weibull_mu, shape = weibull_shape, + Y = rep(weibull_mu, nobs), ... + ) + }, + q_ref = 1, + flags = list(truncation = TRUE) + )) + + frechet_nu <- 3 + frechet_scale <- 1 + frechet_mu <- frechet_scale * gamma(1 - 1 / frechet_nu) + dist_registry_add(dist_entry( + name = "frechet", + backend = "frechet", + type = "continuous", + d = dfrechet, + p = pfrechet, + q = qfrechet, + r = rfrechet, + params = list(scale = frechet_scale, shape = frechet_nu), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_frechet, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_positive( + ns = ns, nobs = nobs, mu = frechet_mu, + extra = list(nu = rep(frechet_nu, ns)), + Y = rep(frechet_mu, nobs), ... + ) + }, + q_ref = 1.2, + flags = list(truncation = TRUE, skip_moments = TRUE) + )) + + dist_registry_add(dist_entry( + name = "gen_extreme_value", + backend = "gen_extreme_value", + type = "continuous", + d = dgen_extreme_value, + p = pgen_extreme_value, + q = qgen_extreme_value, + r = rgen_extreme_value, + params = list(mu = 0, sigma = 1, xi = 0.1), + support = c(-Inf, Inf), + pp_fun = brms:::posterior_predict_gen_extreme_value, + prep_builder = function(ns = 25, ...) { + make_prep_location( + ns = ns, mu = 0, sigma = 1, + extra = list(xi = rep(0.1, ns)), + ... + ) + }, + q_ref = 0.5, + flags = list(truncation = TRUE, skip_moments = TRUE) + )) + + dist_registry_add(dist_entry( + name = "beta", + backend = "beta", + type = "continuous", + d = stats::dbeta, + p = stats::pbeta, + q = stats::qbeta, + r = stats::rbeta, + # PP: shape1 = mu * phi, shape2 = (1 - mu) * phi + params = list(shape1 = 2, shape2 = 3), + support = c(0, 1), + pp_fun = brms:::posterior_predict_beta, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_beta_mix( + ns = ns, nobs = nobs, mu = 0.4, phi = 5, + zoi = 0, coi = 0, Y = rep(0.4, nobs), ... + ) + }, + q_ref = 0.4, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "asym_laplace", + backend = "asym_laplace", + type = "continuous", + d = dasym_laplace, + p = pasym_laplace, + q = qasym_laplace, + r = rasym_laplace, + params = list(mu = 0, sigma = 1, quantile = 0.5), + support = c(-Inf, Inf), + pp_fun = brms:::posterior_predict_asym_laplace, + prep_builder = function(ns = 25, ...) { + make_prep_location( + ns = ns, mu = 0, sigma = 1, + extra = list(quantile = rep(0.5, ns)), + ... + ) + }, + q_ref = 0.25, + flags = list(truncation = TRUE) + )) + + # ---- Discrete ---- + + dist_registry_add(dist_entry( + name = "bernoulli", + backend = "binom", + type = "discrete", + d = stats::dbinom, + p = stats::pbinom, + q = stats::qbinom, + r = stats::rbinom, + params = list(size = 1, prob = 0.4), + support = c(0, 1), + pp_fun = brms:::posterior_predict_bernoulli, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 0.4, trials = 1, + Y = rep(0L, nobs), ... + ) + }, + q_ref = 0, + flags = list(truncation = FALSE) + )) + + dist_registry_add(dist_entry( + name = "negbinomial2", + backend = "nbinom", + type = "discrete", + d = stats::dnbinom, + p = stats::pnbinom, + q = stats::qnbinom, + r = stats::rnbinom, + # PP: size = 1 / sigma + params = list(mu = 4, size = 2.5), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_negbinomial2, + prep_builder = function(ns = 25, nobs = 4, ...) { + p <- make_prep_count( + ns = ns, nobs = nobs, mu = 4, + Y = rep(4L, nobs), ... + ) + p$dpars$sigma <- rep(1 / 2.5, p$ndraws) + p + }, + q_ref = 3, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "geometric", + backend = "nbinom", + type = "discrete", + d = stats::dnbinom, + p = stats::pnbinom, + q = stats::qnbinom, + r = stats::rnbinom, + params = list(mu = 3, size = 1), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_geometric, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 3, shape = 1, + Y = rep(3L, nobs), ... + ) + }, + q_ref = 2, + flags = list(truncation = TRUE) + )) + + dist_registry_add(dist_entry( + name = "discrete_weibull", + backend = "discrete_weibull", + type = "discrete", + d = ddiscrete_weibull, + p = pdiscrete_weibull, + q = qdiscrete_weibull, + r = rdiscrete_weibull, + params = list(mu = 0.7, shape = 1.5), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_discrete_weibull, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 0.7, shape = 1.5, + Y = rep(1L, nobs), ... + ) + }, + q_ref = 1, + flags = list(truncation = TRUE, skip_moments = TRUE) + )) + + # ---- Hurdle / ZI ---- + + dist_registry_add(dist_entry( + name = "hurdle_negbinomial", + backend = "hurdle_negbinomial", + type = "discrete", + d = dhurdle_negbinomial, + p = phurdle_negbinomial, + q = qhurdle_negbinomial, + r = NULL, + params = list(mu = 4, shape = 2.5, hu = 0.2), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_hurdle_negbinomial, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 4, shape = 2.5, hu = 0.2, + Y = rep(3L, nobs), ... + ) + }, + q_ref = 3, + baseline = list( + d = stats::dnbinom, + p = stats::pnbinom, + params = list(mu = 4, size = 2.5), + mix = "hu" + ), + flags = list( + truncation = TRUE, + hurdle = TRUE, + no_random_truncation = TRUE, + skip_moments = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "hurdle_gamma", + backend = "hurdle_gamma", + type = "mixture", + d = dhurdle_gamma, + p = phurdle_gamma, + q = qhurdle_gamma, + r = NULL, + params = list(shape = 2, scale = 1, hu = 0.2), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_hurdle_gamma, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_positive( + ns = ns, nobs = nobs, mu = 2, shape = 2, + extra = list(hu = rep(0.2, ns)), + Y = rep(2, nobs), ... + ) + }, + q_ref = 1.5, + baseline = list( + d = stats::dgamma, + p = stats::pgamma, + params = list(shape = 2, scale = 1), + mix = "hu" + ), + flags = list( + truncation = FALSE, + hurdle = TRUE, + no_random_truncation = TRUE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + has_atoms = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "hurdle_lognormal", + backend = "hurdle_lognormal", + type = "mixture", + d = dhurdle_lognormal, + p = phurdle_lognormal, + q = qhurdle_lognormal, + r = NULL, + params = list(mu = 0, sigma = 1, hu = 0.2), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_hurdle_lognormal, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_location( + ns = ns, nobs = nobs, mu = 0, sigma = 1, + extra = list(hu = rep(0.2, ns)), + Y = rep(1, nobs), ... + ) + }, + q_ref = 1, + baseline = list( + d = stats::dlnorm, + p = stats::plnorm, + params = list(meanlog = 0, sdlog = 1), + mix = "hu" + ), + flags = list( + truncation = FALSE, + hurdle = TRUE, + no_random_truncation = TRUE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + has_atoms = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "zero_inflated_poisson", + backend = "zero_inflated_poisson", + type = "discrete", + d = dzero_inflated_poisson, + p = pzero_inflated_poisson, + q = qzero_inflated_poisson, + r = NULL, + params = list(lambda = 3, zi = 0.25), + support = c(0, Inf), + pp_fun = brms:::posterior_predict_zero_inflated_poisson, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 3, zi = 0.25, + Y = rep(2L, nobs), ... + ) + }, + q_ref = 2, + baseline = list( + d = stats::dpois, + p = stats::ppois, + params = list(lambda = 3), + mix = "zi" + ), + flags = list( + truncation = TRUE, + zi = TRUE, + skip_moments = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "zero_inflated_binomial", + backend = "zero_inflated_binomial", + type = "discrete", + d = dzero_inflated_binomial, + p = pzero_inflated_binomial, + q = qzero_inflated_binomial, + r = NULL, + params = list(size = 10, prob = 0.4, zi = 0.2), + support = c(0, 10), + pp_fun = brms:::posterior_predict_zero_inflated_binomial, + prep_builder = function(ns = 25, nobs = 4, ...) { + make_prep_count( + ns = ns, nobs = nobs, mu = 0.4, trials = 10, zi = 0.2, + Y = rep(4L, nobs), ... + ) + }, + q_ref = 3, + baseline = list( + d = stats::dbinom, + p = stats::pbinom, + params = list(size = 10, prob = 0.4), + mix = "zi" + ), + flags = list( + truncation = TRUE, + zi = TRUE, + skip_moments = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "zero_inflated_beta_binomial", + backend = "zero_inflated_beta_binomial", + type = "discrete", + d = dzero_inflated_beta_binomial, + p = pzero_inflated_beta_binomial, + q = qzero_inflated_beta_binomial, + r = NULL, + params = list(size = 12, mu = 0.35, phi = 8, zi = 0.2), + support = c(0, 12), + ref = list(requires = "extraDistr"), + pp_fun = brms:::posterior_predict_zero_inflated_beta_binomial, + prep_builder = function(ns = 25, nobs = 4, ...) { + p <- make_prep_count( + ns = ns, nobs = nobs, mu = 0.35, trials = 12, zi = 0.2, + Y = rep(4L, nobs), ... + ) + p$dpars$phi <- rep(8, p$ndraws) + p + }, + q_ref = 3, + baseline = list( + d = brms:::dbeta_binomial, + p = brms:::pbeta_binomial, + params = list(size = 12, mu = 0.35, phi = 8), + mix = "zi" + ), + flags = list( + truncation = TRUE, + zi = TRUE, + skip_moments = TRUE + ) + )) + + dist_registry_add(dist_entry( + name = "zero_inflated_beta", + backend = "zero_inflated_beta", + type = "mixture", + d = dzero_inflated_beta, + p = pzero_inflated_beta, + q = qzero_inflated_beta, + r = NULL, + params = list(shape1 = 2, shape2 = 3, zi = 0.25), + support = c(0, 1), + pp_fun = brms:::posterior_predict_zero_inflated_beta, + prep_builder = function(ns = 25, nobs = 4, ...) { + p <- make_prep_beta_mix( + ns = ns, nobs = nobs, mu = 0.4, phi = 5, + zoi = 0, coi = 0, Y = rep(0.4, nobs), ... + ) + p$dpars$zi <- rep(0.25, p$ndraws) + p + }, + q_ref = 0.4, + flags = list( + truncation = FALSE, + zi = TRUE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + has_atoms = TRUE + ) + )) + + # ---- Ordinal variants ---- + + register_ordinal_variant <- function(fam) { + dist_registry_add(dist_entry( + name = paste0("ordinal_", fam), + backend = "ordinal", + type = "ordinal", + d = function(x, ...) { + brms:::dordinal(x, family = fam, link = "logit", ...) + }, + p = function(q, ...) { + brms:::pordinal(q, family = fam, link = "logit", ...) + }, + q = function(p, ...) { + brms:::qordinal(p, family = fam, link = "logit", ...) + }, + r = function(n, ...) { + brms:::rordinal(n, family = fam, link = "logit", ...) + }, + params = list( + eta = 0, + thres = matrix(c(-1, 0, 1), nrow = 1), + disc = 1 + ), + support = c(1, 4), + pp_fun = brms:::posterior_predict_ordinal, + prep_builder = function(...) { + make_prep_ordinal(family = fam, ...) + }, + q_ref = 2, + flags = list( + truncation = FALSE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_pdf_fd = TRUE, + skip_rng_cdf = TRUE, + skip_p_tail_flags = TRUE + ) + )) + } + for (ord_fam in c("sratio", "cratio", "acat")) { + register_ordinal_variant(ord_fam) + } + + # ---- Stubs (no deep d/p/q) ---- + + stub_names_random <- c( + "gaussian_mv", "student_mv", + "gaussian_time", "student_time", + "gaussian_lagsar", "student_lagsar", + "gaussian_errorsar", "student_errorsar", + "gaussian_fcor", "student_fcor", + "multinomial", "dirichlet_multinomial", + "dirichlet", "dirichlet2", "logistic_normal", + "mixture" + ) + for (nm in stub_names_random) { + dist_registry_add(dist_entry( + name = nm, + backend = nm, + type = "continuous", + d = NULL, + p = NULL, + q = NULL, + r = NULL, + params = list(), + support = c(-Inf, Inf), + pp_fun = NULL, + prep_builder = NULL, + outputs = c("random"), + flags = list( + stub = TRUE, + truncation = FALSE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_rng_cdf = TRUE, + skip_pdf_fd = TRUE + ) + )) + } + + dist_registry_add(dist_entry( + name = "cox", + backend = "cox", + type = "continuous", + d = NULL, + p = NULL, + q = NULL, + r = NULL, + params = list(), + support = c(0, Inf), + pp_fun = NULL, + prep_builder = NULL, + outputs = character(0), + flags = list( + stub = TRUE, + truncation = FALSE, + skip_integrate = TRUE, + skip_moments = TRUE, + skip_rng_cdf = TRUE, + skip_pdf_fd = TRUE + ) + )) + + invisible(.dist_registry_env$entries) +} + +# Ensure registry is available when helpers are sourced +dist_registry_populate() + +# --------------------------------------------------------------------------- +# Custom expectations: d/p/q/r relations +# --------------------------------------------------------------------------- + +expect_pq_inverse <- function(entry, p = c(0.01, 0.1, 0.5, 0.85, 0.99), + tol = 1e-6) { + testthat::expect_true(has_fun(entry, "p") && has_fun(entry, "q")) + # Ordinal/categorical q*() treat length(p) as ndraws when eta is scalar; + # evaluate each probability separately. Mixture atoms make p(q(p))=p fail. + elementwise <- entry$type %in% c("ordinal", "mixture") || + isTRUE(entry$flags$pq_elementwise) + use_discrete_def <- isTRUE(entry$flags$discrete_support) || + entry$type == "mixture" || + isTRUE(entry$flags$has_atoms) + + if (elementwise) { + q <- vapply(p, function(pj) { + as.numeric(call_dist(entry$q, pj, entry$params))[1] + }, numeric(1)) + F_q <- vapply(q, function(qj) { + as.numeric(call_dist(entry$p, qj, entry$params))[1] + }, numeric(1)) + F_qm1 <- vapply(q, function(qj) { + as.numeric(call_dist(entry$p, qj - 1, entry$params))[1] + }, numeric(1)) + } else { + q <- as.numeric(call_dist(entry$q, p, entry$params)) + F_q <- as.numeric(call_dist(entry$p, q, entry$params)) + F_qm1 <- as.numeric(call_dist(entry$p, q - 1, entry$params)) + } + + if (use_discrete_def) { + testthat::expect_true(all(F_q + tol >= p), + info = paste(entry$name, "F(q) >= p")) + if (isTRUE(entry$flags$discrete_support)) { + ok <- ifelse(q > entry$support[1], F_qm1 < p + tol, TRUE) + testthat::expect_true(all(ok), + info = paste(entry$name, "F(q-1) < p")) + } + } else { + testthat::expect_equal(F_q, p, tolerance = tol, + info = paste(entry$name, "p(q(p))")) + } + invisible(TRUE) +} + +expect_qp_inverse <- function(entry, x = NULL, tol = 1e-5) { + testthat::expect_true(has_fun(entry, "p") && has_fun(entry, "q")) + if (isTRUE(entry$flags$discrete_support) || + entry$type == "mixture" || + isTRUE(entry$flags$has_atoms)) { + return(invisible(TRUE)) + } + if (is.null(x)) { + lo <- entry$support[1] + hi <- entry$support[2] + if (!is.finite(lo)) lo <- call_dist(entry$q, 0.05, entry$params) + if (!is.finite(hi)) hi <- call_dist(entry$q, 0.95, entry$params) + x <- as.numeric(seq(lo, hi, length.out = 7)) + } + # avoid endpoints where q(p) is unstable for numeric inverses + p <- call_dist(entry$p, x, entry$params) + keep <- is.finite(p) & p > 1e-4 & p < 1 - 1e-4 + if (!any(keep)) return(invisible(TRUE)) + x <- x[keep] + p <- p[keep] + x2 <- call_dist(entry$q, p, entry$params) + testthat::expect_equal(as.numeric(x2), as.numeric(x), tolerance = tol, + info = paste(entry$name, "q(p(x))")) + invisible(TRUE) +} + +expect_d_sums_to_p <- function(entry, k = NULL, tol = 1e-8) { + testthat::expect_true(has_fun(entry, "d") && has_fun(entry, "p")) + testthat::expect_true(isTRUE(entry$flags$discrete_support)) + if (isTRUE(entry$flags$skip_d_sums)) return(invisible(TRUE)) + if (is.null(k)) { + hi <- entry$support[2] + if (!is.finite(hi)) { + hi <- as.integer(call_dist(entry$q, 0.999, entry$params)) + 2L + } + lo <- max(0L, as.integer(entry$support[1])) + k <- lo:hi + } + dens <- as.numeric(call_dist(entry$d, k, entry$params)) + if (isTRUE(entry$flags$pq_elementwise)) { + cdf <- vapply(k, function(kj) { + as.numeric(call_dist(entry$p, kj, entry$params))[1] + }, numeric(1)) + } else { + cdf <- as.numeric(call_dist(entry$p, k, entry$params)) + } + # F(k) = sum_{j<=k} f(j); compare consecutive differences + pmf_from_cdf <- c(cdf[1], diff(cdf)) + # for support starting above min(k), first mass may include left tail + if (k[1] > entry$support[1] || k[1] > 0) { + F_prev <- as.numeric(call_dist(entry$p, k[1] - 1, entry$params))[1] + pmf_from_cdf[1] <- cdf[1] - F_prev + } + testthat::expect_equal(dens, pmf_from_cdf, tolerance = tol, + info = paste(entry$name, "d == diff(p)")) + invisible(TRUE) +} + +expect_pdf_matches_cdf_fd <- function(entry, x = NULL, eps = 1e-5, + tol = 5e-3) { + testthat::expect_true(has_fun(entry, "d") && has_fun(entry, "p")) + if (isTRUE(entry$flags$discrete_support) || isTRUE(entry$flags$skip_pdf_fd)) { + return(invisible(TRUE)) + } + if (is.null(x)) { + qs <- call_dist(entry$q, c(0.2, 0.4, 0.6, 0.8), entry$params) + x <- as.numeric(qs) + } + dens <- as.numeric(call_dist(entry$d, x, entry$params)) + fd <- (as.numeric(call_dist(entry$p, x + eps, entry$params)) - + as.numeric(call_dist(entry$p, x - eps, entry$params))) / (2 * eps) + testthat::expect_equal(dens, fd, tolerance = tol, + info = paste(entry$name, "d ≈ F'")) + invisible(TRUE) +} + +expect_integrates_to_one <- function(entry, tol = 1e-3) { + testthat::expect_true(has_fun(entry, "d")) + if (isTRUE(entry$flags$skip_integrate)) return(invisible(TRUE)) + if (isTRUE(entry$flags$discrete_support)) { + hi <- entry$support[2] + if (!is.finite(hi)) { + hi <- as.integer(call_dist(entry$q, 0.9999, entry$params)) + 20L + } + lo <- max(0L, as.integer(entry$support[1])) + s <- sum(as.numeric(call_dist(entry$d, lo:hi, entry$params))) + testthat::expect_equal(s, 1, tolerance = tol, + info = paste(entry$name, "sum d = 1")) + } else { + lo <- entry$support[1] + hi <- entry$support[2] + if (!is.finite(lo)) lo <- as.numeric(call_dist(entry$q, 1e-6, entry$params)) - 1 + if (!is.finite(hi)) hi <- as.numeric(call_dist(entry$q, 1 - 1e-6, entry$params)) + 1 + integrand <- function(x) { + as.numeric(call_dist(entry$d, x, entry$params)) + } + s <- stats::integrate(integrand, lo, hi, rel.tol = 1e-4)$value + testthat::expect_equal(s, 1, tolerance = tol, + info = paste(entry$name, "∫ d = 1")) + } + invisible(TRUE) +} + +expect_log_and_tail_flags <- function(entry, x = NULL, p = 0.2) { + if (is.null(x)) { + x <- if (isTRUE(entry$flags$discrete_support)) { + entry$q_ref + } else { + as.numeric(call_dist(entry$q, 0.4, entry$params)) + } + } + if (has_fun(entry, "d")) { + d0 <- as.numeric(call_dist(entry$d, x, entry$params, log = FALSE)) + d1 <- as.numeric(call_dist(entry$d, x, entry$params, log = TRUE)) + testthat::expect_equal(d1, log(d0), tolerance = 1e-8, + info = paste(entry$name, "d log")) + } + if (has_fun(entry, "p") && !isTRUE(entry$flags$skip_p_tail_flags)) { + pl <- as.numeric(call_dist(entry$p, x, entry$params, + lower.tail = TRUE, log.p = FALSE)) + pu <- as.numeric(call_dist(entry$p, x, entry$params, + lower.tail = FALSE, log.p = FALSE)) + testthat::expect_equal(pl + pu, 1, tolerance = 1e-8, + info = paste(entry$name, "p tails")) + pll <- as.numeric(call_dist(entry$p, x, entry$params, + lower.tail = TRUE, log.p = TRUE)) + testthat::expect_equal(pll, log(pl), tolerance = 1e-8, + info = paste(entry$name, "p log.p")) + } + if (has_fun(entry, "q")) { + q_up <- as.numeric(call_dist(entry$q, p, entry$params, + lower.tail = FALSE, log.p = FALSE)) + q_lo <- as.numeric(call_dist(entry$q, 1 - p, entry$params, + lower.tail = TRUE, log.p = FALSE)) + testthat::expect_equal(q_up, q_lo, tolerance = 1e-6, + info = paste(entry$name, "q lower.tail")) + q_log <- as.numeric(call_dist(entry$q, log(p), entry$params, + lower.tail = TRUE, log.p = TRUE)) + q_ref <- as.numeric(call_dist(entry$q, p, entry$params, + lower.tail = TRUE, log.p = FALSE)) + testthat::expect_equal(q_log, q_ref, tolerance = 1e-6, + info = paste(entry$name, "q log.p")) + } + invisible(TRUE) +} + +expect_moments_match <- function(entry, n = 8000, tol = 0.15, seed = 1) { + if (!has_fun(entry, "r") || isTRUE(entry$flags$skip_moments)) { + return(invisible(TRUE)) + } + withr::local_seed(seed) + draws <- as.numeric(do.call(entry$r, c(list(n), entry$params))) + # approximate mean via quantile grid when closed form unknown + ps <- seq(0.001, 0.999, length.out = 500) + qs <- as.numeric(call_dist(entry$q, ps, entry$params)) + mean_ref <- mean(qs) + testthat::expect_equal(mean(draws), mean_ref, tolerance = tol, + info = paste(entry$name, "E[X]")) + invisible(TRUE) +} + +expect_rng_fits_cdf <- function(entry, n = 4000, tol = 0.08, seed = 2) { + if (!has_fun(entry, "r") || !has_fun(entry, "p") || + isTRUE(entry$flags$skip_rng_cdf)) { + return(invisible(TRUE)) + } + withr::local_seed(seed) + draws <- as.numeric(do.call(entry$r, c(list(n), entry$params))) + u <- as.numeric(call_dist(entry$p, draws, entry$params)) + # continuous: PIT ~ U(0,1); discrete: not uniform — compare ECDF at probes + if (isTRUE(entry$flags$discrete_support)) { + probes <- as.numeric(call_dist(entry$q, c(0.25, 0.5, 0.75), entry$params)) + for (qk in unique(probes)) { + emp <- mean(draws <= qk) + th <- as.numeric(call_dist(entry$p, qk, entry$params)) + testthat::expect_equal(emp, th, tolerance = tol, + info = paste(entry$name, "ECDF at", qk)) + } + } else { + testthat::expect_equal(mean(u), 0.5, tolerance = tol, + info = paste(entry$name, "mean PIT")) + testthat::expect_true( + abs(mean(u < 0.5) - 0.5) < tol, + info = paste(entry$name, "P(PIT<0.5)") + ) + } + invisible(TRUE) +} + +expect_truncated_cdf_density_quantile <- function(entry, lb, ub, + q = NULL, p = 0.4, + tol = 1e-7) { + if (!has_fun(entry, "p") || !isTRUE(entry$flags$truncation)) { + return(invisible(TRUE)) + } + if (is.null(q)) q <- entry$q_ref + F <- function(x) as.numeric(call_dist(entry$p, x, entry$params)) + denom <- F(ub) - F(lb) + testthat::expect_true(denom > 0, info = paste(entry$name, "trunc mass")) + + # truncated CDF (cheatsheet) + F_tr <- (F(q) - F(lb)) / denom + F_tr_pp <- do.call( + brms:::compute_cdf, + c(list(q = q, distribution = entry$backend, lb = lb, ub = ub, + randomized = FALSE), entry$params) + ) + testthat::expect_equal(as.numeric(F_tr_pp), F_tr, tolerance = tol, + info = paste(entry$name, "trunc CDF")) + + if (has_fun(entry, "d")) { + dens <- as.numeric(call_dist(entry$d, q, entry$params)) + dens_tr <- if (q < lb || q > ub) 0 else dens / denom + dens_pp <- do.call( + brms:::compute_density, + c(list(q = q, distribution = entry$backend, lb = lb, ub = ub), + entry$params) + ) + testthat::expect_equal(as.numeric(dens_pp), dens_tr, tolerance = tol, + info = paste(entry$name, "trunc density")) + } + + if (has_fun(entry, "q")) { + p_star <- p * denom + F(lb) + q_tr <- as.numeric(call_dist(entry$q, p_star, entry$params)) + q_pp <- do.call( + brms:::compute_quantile, + c(list(p = p, distribution = entry$backend, lb = lb, ub = ub), + entry$params) + ) + testthat::expect_equal(as.numeric(q_pp), q_tr, tolerance = 1e-5, + info = paste(entry$name, "trunc quantile")) + } + invisible(TRUE) +} + +expect_zi_hurdle_mixture <- function(entry, y = 0:8, tol = 1e-8) { + if (is.null(entry$baseline)) return(invisible(TRUE)) + base <- entry$baseline + pi <- entry$params[[base$mix]] + g_d <- function(x) as.numeric(call_dist(base$d, x, base$params)) + g_p <- function(x) as.numeric(call_dist(base$p, x, base$params)) + + if (isTRUE(entry$flags$zi)) { + # P(Y=0) = pi + (1-pi) G(0); P(Y=y>0) = (1-pi) g(y) + # For PMF comparison use d; for y=0 use point mass formula + d0 <- as.numeric(call_dist(entry$d, 0, entry$params)) + testthat::expect_equal( + d0, pi + (1 - pi) * g_d(0), tolerance = tol, + info = paste(entry$name, "ZI d(0)") + ) + ypos <- y[y > 0] + if (length(ypos)) { + d_y <- as.numeric(call_dist(entry$d, ypos, entry$params)) + testthat::expect_equal( + d_y, (1 - pi) * g_d(ypos), tolerance = tol, + info = paste(entry$name, "ZI d(y>0)") + ) + } + } + if (isTRUE(entry$flags$hurdle)) { + # P(Y=0)=h; P(Y=y>0)=(1-h) g(y)/(1-G(0)) + d0 <- as.numeric(call_dist(entry$d, 0, entry$params)) + testthat::expect_equal(d0, pi, tolerance = tol, + info = paste(entry$name, "hurdle d(0)")) + ypos <- y[y > 0] + if (length(ypos)) { + d_y <- as.numeric(call_dist(entry$d, ypos, entry$params)) + testthat::expect_equal( + d_y, (1 - pi) * g_d(ypos) / (1 - g_p(0)), tolerance = tol, + info = paste(entry$name, "hurdle d(y>0)") + ) + } + } + invisible(TRUE) +} diff --git a/tests/testthat/helper-posterior-predict.R b/tests/testthat/helper-posterior-predict.R new file mode 100644 index 000000000..012f2cd30 --- /dev/null +++ b/tests/testthat/helper-posterior-predict.R @@ -0,0 +1,331 @@ +# posterior_predict contract helpers +# Depends on helper-distributions.R (sourced first alphabetically). + +# Registry entries suitable for posterior_predict contract tests +pp_test_entries <- function(truncation = FALSE) { + dist_active_entries( + require_funs = "pp_fun", + truncation = if (truncation) TRUE else NULL + ) +} + +skip_if_entry_missing_deps <- function(entry) { + for (pkg in entry_requires(entry)) { + testthat::skip_if_not_installed(pkg) + } + invisible(TRUE) +} + +# --------------------------------------------------------------------------- +# posterior_predict expectations +# --------------------------------------------------------------------------- + +expect_pp_output_matches_dist <- function(entry, i = 1L, tol = 1e-7, + seed = 42) { + testthat::expect_true(has_fun(entry, "pp_fun")) + prep <- entry$prep_builder(ns = 15, nobs = max(3, i), seed = seed) + q <- entry$q_ref + p <- entry$p_ref + pp <- entry$pp_fun + + if (has_output(entry, "probability") && has_fun(entry, "p")) { + got <- pp(i, prep = prep, output = "probability", q = q) + # constant dpars => all draws equal scalar CDF + exp_val <- as.numeric(call_dist(entry$p, q, entry$params)) + # ordinal/categorical may return length-1 or matrix; coerce + if (length(exp_val) > 1L) exp_val <- exp_val[1] + testthat::expect_equal( + as.numeric(got), rep(as.numeric(exp_val), prep$ndraws), + tolerance = tol, + info = paste(entry$name, "PP probability") + ) + } + + if (has_output(entry, "density") && has_fun(entry, "d")) { + got <- pp(i, prep = prep, output = "density", q = q) + exp_val <- as.numeric(call_dist(entry$d, q, entry$params)) + if (length(exp_val) > 1L) exp_val <- exp_val[1] + testthat::expect_equal( + as.numeric(got), rep(as.numeric(exp_val), prep$ndraws), + tolerance = tol, + info = paste(entry$name, "PP density") + ) + } + + if (has_output(entry, "quantile") && has_fun(entry, "q")) { + got <- pp(i, prep = prep, output = "quantile", p = p) + exp_val <- as.numeric(call_dist(entry$q, p, entry$params)) + if (length(exp_val) > 1L) exp_val <- exp_val[1] + testthat::expect_equal( + as.numeric(got), rep(as.numeric(exp_val), prep$ndraws), + tolerance = 1e-5, + info = paste(entry$name, "PP quantile") + ) + } + + if (has_output(entry, "random")) { + withr::local_seed(seed) + got <- pp(i, prep = prep, output = "random") + testthat::expect_length(got, prep$ndraws) + testthat::expect_true(all(is.finite(got))) + lo <- entry$support[1] + hi <- entry$support[2] + if (is.finite(lo)) testthat::expect_true(all(got >= lo - 1e-8)) + if (is.finite(hi)) testthat::expect_true(all(got <= hi + 1e-8)) + } + invisible(TRUE) +} + +# Map prep dpars to compute_cdf / backend args for randomized PIT checks. +# Keyed by registry entry$name; ordinal_* share the "ordinal" builder. +.pp_dist_args_from_prep <- list( + ordinal = function(prep, i) { + list( + eta = prep$dpars$mu[, i], + thres = prep$thres$thres, + disc = prep$dpars$disc, + family = prep$family$family, + link = prep$family$link + ) + }, + categorical = function(prep, i) { + Mu <- brms:::get_Mu(prep, i = i) + list(eta = brms:::insert_refcat(Mu, refcat = prep$refcat)) + }, + hurdle_cumulative = function(prep, i) { + list( + eta = prep$dpars$mu[, i], + thres = prep$thres$thres, + hu = prep$dpars$hu, + disc = prep$dpars$disc, + link = "logit" + ) + }, + pois = function(prep, i) { + list(lambda = prep$dpars$mu[, i]) + }, + binom = function(prep, i) { + list(size = prep$data$trials[i], prob = prep$dpars$mu[, i]) + }, + bernoulli = function(prep, i) { + list(size = prep$data$trials[i], prob = prep$dpars$mu[, i]) + }, + beta_binomial = function(prep, i) { + list( + size = prep$data$trials[i], + mu = prep$dpars$mu[, i], + phi = prep$dpars$phi + ) + }, + nbinom = function(prep, i) { + list(mu = prep$dpars$mu[, i], size = prep$dpars$shape) + }, + negbinomial2 = function(prep, i) { + list(mu = prep$dpars$mu[, i], size = 1 / prep$dpars$sigma) + }, + geometric = function(prep, i) { + list(mu = prep$dpars$mu[, i], size = rep(1, prep$ndraws)) + }, + com_poisson = function(prep, i) { + list(mu = prep$dpars$mu[, i], shape = prep$dpars$shape) + }, + discrete_weibull = function(prep, i) { + list(mu = prep$dpars$mu[, i], shape = prep$dpars$shape) + }, + hurdle_poisson = function(prep, i) { + list(lambda = prep$dpars$mu[, i], hu = prep$dpars$hu) + }, + hurdle_negbinomial = function(prep, i) { + list( + mu = prep$dpars$mu[, i], + shape = prep$dpars$shape, + hu = prep$dpars$hu + ) + }, + zero_inflated_negbinomial = function(prep, i) { + list( + mu = prep$dpars$mu[, i], + shape = prep$dpars$shape, + zi = prep$dpars$zi + ) + }, + zero_inflated_poisson = function(prep, i) { + list(lambda = prep$dpars$mu[, i], zi = prep$dpars$zi) + }, + zero_inflated_binomial = function(prep, i) { + list( + size = prep$data$trials[i], + prob = prep$dpars$mu[, i], + zi = prep$dpars$zi + ) + }, + zero_inflated_beta_binomial = function(prep, i) { + list( + size = prep$data$trials[i], + mu = prep$dpars$mu[, i], + phi = prep$dpars$phi, + zi = prep$dpars$zi + ) + } +) + +expand_scalar_params <- function(params, ndraws) { + lapply(params, function(a) { + if (is.atomic(a) && !is.null(a) && length(a) == 1L) { + rep(a, ndraws) + } else { + a + } + }) +} + +get_pp_dist_args <- function(entry, prep, i) { + key <- entry$name + if (entry$backend == "ordinal" || grepl("^ordinal_", key)) { + key <- "ordinal" + } + fun <- .pp_dist_args_from_prep[[key]] + if (is.null(fun)) { + expand_scalar_params(entry$params, prep$ndraws) + } else { + fun(prep, i) + } +} + +expect_pp_pit_contract <- function(entry, i = 1L, seed = 99, tol = 1e-8) { + testthat::expect_true(has_fun(entry, "pp_fun")) + if (!has_output(entry, "pit") || !has_output(entry, "probability")) { + return(invisible(TRUE)) + } + prep <- entry$prep_builder(ns = 40, nobs = max(3, i), seed = seed) + q <- entry$q_ref + pp <- entry$pp_fun + + if (entry$type %in% c("continuous", "circular", "mixture") && + !isTRUE(entry$flags$discrete_support)) { + prob <- pp(i, prep = prep, output = "probability", q = q) + pit <- pp(i, prep = prep, output = "pit", q = q) + testthat::expect_equal(pit, prob, tolerance = tol, + info = paste(entry$name, "PIT ≡ probability")) + } else { + # discrete / ordinal: randomized PIT = F(q-1) + V*(F(q)-F(q-1)) + withr::local_seed(seed) + pit <- pp(i, prep = prep, output = "pit", q = q) + withr::local_seed(seed) + args <- get_pp_dist_args(entry, prep, i) + expected <- do.call( + brms:::compute_cdf, + c(list(q = q, distribution = entry$backend, lb = NULL, ub = NULL, + randomized = TRUE), args) + ) + testthat::expect_equal(pit, expected, tolerance = tol, + info = paste(entry$name, "randomized PIT")) + Fq <- do.call( + brms:::compute_cdf, + c(list(q = q, distribution = entry$backend, lb = NULL, ub = NULL, + randomized = FALSE), args) + ) + Fqm1 <- do.call( + brms:::compute_cdf, + c(list(q = q - 1, distribution = entry$backend, lb = NULL, ub = NULL, + randomized = FALSE), args) + ) + testthat::expect_true(all(pit >= pmin(Fqm1, Fq) - 1e-10 & + pit <= pmax(Fqm1, Fq) + 1e-10), + info = paste(entry$name, "PIT in [F(q-1), F(q)]")) + } + invisible(TRUE) +} + +expect_pp_truncation <- function(entry, i = 1L, lb = NULL, ub = NULL, + tol = 1e-7, seed = 7) { + if (!isTRUE(entry$flags$truncation) || !has_fun(entry, "pp_fun")) { + return(invisible(TRUE)) + } + if (is.null(lb) || is.null(ub)) { + if (isTRUE(entry$flags$discrete_support)) { + lb <- 1 + ub <- 6 + } else { + qs <- as.numeric(call_dist(entry$q, c(0.15, 0.85), entry$params)) + lb <- qs[1] + ub <- qs[2] + } + } + prep <- entry$prep_builder(ns = 12, nobs = max(3, i), seed = seed) + prep <- set_trunc_bounds(prep, lb = lb, ub = ub, i = i) + q <- entry$q_ref + # clamp q into [lb, ub] for density/prob checks + q_in <- min(max(q, lb), ub) + + got_p <- entry$pp_fun(i, prep = prep, output = "probability", q = q_in) + exp_p <- do.call( + brms:::compute_cdf, + c(list(q = q_in, distribution = entry$backend, lb = lb, ub = ub, + randomized = FALSE), entry$params) + ) + testthat::expect_equal(got_p, rep(as.numeric(exp_p), prep$ndraws), + tolerance = tol, + info = paste(entry$name, "PP trunc probability")) + + if (has_output(entry, "density")) { + got_d <- entry$pp_fun(i, prep = prep, output = "density", q = q_in) + exp_d <- do.call( + brms:::compute_density, + c(list(q = q_in, distribution = entry$backend, lb = lb, ub = ub), + entry$params) + ) + testthat::expect_equal(got_d, rep(as.numeric(exp_d), prep$ndraws), + tolerance = tol, + info = paste(entry$name, "PP trunc density")) + } + + if (has_output(entry, "quantile")) { + got_q <- entry$pp_fun(i, prep = prep, output = "quantile", p = 0.4) + exp_q <- do.call( + brms:::compute_quantile, + c(list(p = 0.4, distribution = entry$backend, lb = lb, ub = ub), + entry$params) + ) + testthat::expect_equal(got_q, rep(as.numeric(exp_q), prep$ndraws), + tolerance = 1e-5, + info = paste(entry$name, "PP trunc quantile")) + } + invisible(TRUE) +} + +expect_pp_log_tail_flags <- function(entry, i = 1L, seed = 11) { + if (!has_fun(entry, "pp_fun")) return(invisible(TRUE)) + prep <- entry$prep_builder(ns = 8, nobs = max(3, i), seed = seed) + q <- entry$q_ref + p <- entry$p_ref + pp <- entry$pp_fun + + if (has_output(entry, "probability")) { + pl <- pp(i, prep = prep, output = "probability", q = q, + lower.tail = TRUE, log.p = FALSE) + pu <- pp(i, prep = prep, output = "probability", q = q, + lower.tail = FALSE, log.p = FALSE) + testthat::expect_equal(pl + pu, rep(1, prep$ndraws), tolerance = 1e-7, + info = paste(entry$name, "PP p tails")) + pll <- pp(i, prep = prep, output = "probability", q = q, + lower.tail = TRUE, log.p = TRUE) + testthat::expect_equal(pll, log(pl), tolerance = 1e-7, + info = paste(entry$name, "PP p log.p")) + } + if (has_output(entry, "density")) { + d0 <- pp(i, prep = prep, output = "density", q = q, log = FALSE) + d1 <- pp(i, prep = prep, output = "density", q = q, log = TRUE) + testthat::expect_equal(d1, log(d0), tolerance = 1e-7, + info = paste(entry$name, "PP d log")) + } + if (has_output(entry, "quantile")) { + q_up <- pp(i, prep = prep, output = "quantile", p = p, + lower.tail = FALSE) + q_lo <- pp(i, prep = prep, output = "quantile", p = 1 - p, + lower.tail = TRUE) + testthat::expect_equal(q_up, q_lo, tolerance = 1e-5, + info = paste(entry$name, "PP q lower.tail")) + } + invisible(TRUE) +} diff --git a/tests/testthat/tests.distributions_analytical.R b/tests/testthat/tests.distributions_analytical.R new file mode 100644 index 000000000..d8876a018 --- /dev/null +++ b/tests/testthat/tests.distributions_analytical.R @@ -0,0 +1,271 @@ +context("Distribution validation: analytical / known values") + +test_that("gaussian matches stats:: reference", { + entry <- dist_registry_get("gaussian")[[1]] + x <- c(-2, -0.5, 0, 1.2) + expect_equal( + call_dist(entry$d, x, entry$params), + dnorm(x, mean = 0, sd = 1) + ) + expect_equal( + call_dist(entry$p, x, entry$params), + pnorm(x, mean = 0, sd = 1) + ) + p <- c(0.1, 0.5, 0.9) + expect_equal( + call_dist(entry$q, p, entry$params), + qnorm(p, mean = 0, sd = 1) + ) +}) + +test_that("student_t matches scaled stats::t", { + entry <- dist_registry_get("student_t")[[1]] + x <- c(-1, 0, 2) + df <- entry$params$df + sigma <- entry$params$sigma + mu <- entry$params$mu + expect_equal( + call_dist(entry$d, x, entry$params), + dt((x - mu) / sigma, df = df) / sigma + ) + expect_equal( + call_dist(entry$p, x, entry$params), + pt((x - mu) / sigma, df = df) + ) +}) + +test_that("com_poisson reduces to Poisson when shape = 1", { + entry <- dist_registry_get("com_poisson")[[1]] + mu <- 3 + p <- c(0.1, 0.5, 0.9) + expect_equal( + brms:::qcom_poisson(p, mu = mu, shape = 1), + qpois(p, lambda = mu) + ) + x <- 0:8 + expect_equal( + brms:::dcom_poisson(x, mu = mu, shape = 1), + dpois(x, lambda = mu), + tolerance = 1e-6 + ) +}) + +test_that("qexgaussian handles probabilities outside (0, 1)", { + entry <- dist_registry_get("exgaussian")[[1]] + res <- SW(call_dist(entry$q, c(-1, 0, 1, 1.5), entry$params)) + expect_equal(res, c(NA, -Inf, Inf, NA)) +}) + +test_that("qvon_mises handles probabilities outside (0, 1) and stays in (-pi, pi)", { + entry <- dist_registry_get("von_mises")[[1]] + q <- call_dist(entry$q, c(0.1, 0.5, 0.9), entry$params) + expect_true(all(q >= -pi & q <= pi)) + res <- SW(call_dist(entry$q, c(-1, 0, 0.5, 1, 1.5), entry$params)) + expect_equal(res[1], NA_real_) + expect_equal(res[2], -pi) + expect_equal(res[4], pi) + expect_equal(res[5], NA_real_) +}) + + +test_that("qzero_one_inflated_beta matches mixture CDF boundaries", { + entry <- dist_registry_get("zero_one_inflated_beta")[[1]] + zoi <- entry$params$zoi + coi <- entry$params$coi + p0 <- zoi * (1 - coi) + p1 <- zoi * coi + p <- c(0.01, 0.1, 0.2, 0.5, 0.9, 0.95, 0.99) + q <- call_dist(entry$q, p, entry$params) + expect_equal(q[p <= p0], rep(0, sum(p <= p0))) + expect_equal(q[p >= 1 - p1], rep(1, sum(p >= 1 - p1))) + expect_true(all(q[p > p0 & p < 1 - p1] > 0 & q[p > p0 & p < 1 - p1] < 1)) + expect_true(all(diff(q) >= 0)) + F_q <- call_dist(entry$p, q, entry$params) + expect_true(all(as.numeric(F_q) + 1e-8 >= p)) +}) + +test_that("qzero_inflated_asym_laplace matches mixture CDF regions", { + entry <- dist_registry_get("zero_inflated_asym_laplace")[[1]] + mu <- entry$params$mu + sigma <- entry$params$sigma + quantile <- entry$params$quantile + zi <- entry$params$zi + p <- c(0.01, 0.1, 0.3, 0.5, 0.65, 0.85, 0.99) + q <- call_dist(entry$q, p, entry$params) + F0_base <- pasym_laplace(0, mu = mu, sigma = sigma, quantile = quantile) + F0_minus <- (1 - zi) * F0_base + F0 <- zi + (1 - zi) * F0_base + expect_true(all(q[p < F0_minus] < 0)) + expect_equal(q[p >= F0_minus & p <= F0], + rep(0, sum(p >= F0_minus & p <= F0))) + expect_true(all(q[p > F0] > 0)) + expect_true(all(diff(q) >= 0)) + F_q <- call_dist(entry$p, q, entry$params) + expect_true(all(as.numeric(F_q) + 1e-8 >= p)) +}) + +test_that("qordinal matches the ordinal CDF", { + withr::local_seed(11) + ns <- 7 + nthres <- 3 + eta <- rnorm(ns) + thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) + disc <- rep(1, ns) + p <- c(0.05, 0.25, 0.5, 0.75, 0.95) + for (fam in c("cumulative", "sratio", "cratio", "acat")) { + F_mat <- brms:::pordinal( + seq_len(nthres + 1), eta = eta, thres = thres, disc = disc, + family = fam, link = "logit" + ) + for (pj in p) { + qj <- brms:::qordinal( + pj, eta = eta, thres = thres, disc = disc, + family = fam, link = "logit" + ) + expect_length(qj, ns) + expect_true(all(qj >= 1 & qj <= nthres + 1)) + expect_true(all(F_mat[cbind(seq_len(ns), qj)] + 1e-10 >= pj)) + expect_true(all( + ifelse(qj > 1, F_mat[cbind(seq_len(ns), qj - 1)] < pj + 1e-10, TRUE) + )) + } + } +}) + +test_that("qcategorical matches the categorical CDF", { + withr::local_seed(12) + ns <- 7 + ncat <- 4 + eta <- matrix(rnorm(ns * ncat), nrow = ns) + p <- c(0.05, 0.25, 0.5, 0.75, 0.95) + F_mat <- brms:::pcategorical(seq_len(ncat), eta = eta) + for (pj in p) { + qj <- brms:::qcategorical(pj, eta = eta) + expect_length(qj, ns) + expect_true(all(qj >= 1 & qj <= ncat)) + expect_true(all(F_mat[cbind(seq_len(ns), qj)] + 1e-10 >= pj)) + expect_true(all( + ifelse(qj > 1, F_mat[cbind(seq_len(ns), qj - 1)] < pj + 1e-10, TRUE) + )) + } +}) + +test_that("qhurdle_cumulative matches the mixture CDF", { + withr::local_seed(13) + ns <- 7 + nthres <- 3 + ncat <- nthres + 1 + eta <- rnorm(ns) + thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) + disc <- rep(1, ns) + hu <- rep(0.25, ns) + p <- c(0.05, 0.2, 0.25, 0.5, 0.9, 0.99) + for (pj in p) { + qj <- brms:::qhurdle_cumulative( + pj, eta = eta, thres = thres, hu = hu, disc = disc, link = "logit" + ) + expect_length(qj, ns) + expect_true(all(qj >= 0 & qj <= ncat)) + F_q <- vapply(seq_len(ns), function(s) { + brms:::phurdle_cumulative( + qj[s], eta = eta[s], thres = thres[s, , drop = FALSE], + hu = hu[s], disc = disc[s], link = "logit" + ) + }, numeric(1)) + expect_true(all(F_q + 1e-10 >= pj)) + } + expect_equal( + brms:::qhurdle_cumulative( + 0.1, eta = eta, thres = thres, hu = hu, disc = disc, link = "logit" + ), + rep(0, ns) + ) +}) + +test_that("beta_binomial matches extraDistr when available", { + skip_if_not_installed("extraDistr") + entry <- dist_registry_get("beta_binomial")[[1]] + size <- entry$params$size + mu <- entry$params$mu + phi <- entry$params$phi + # extraDistr uses alpha, beta parameterization + alpha <- mu * phi + beta <- (1 - mu) * phi + x <- 0:size + expect_equal( + as.numeric(call_dist(entry$d, x, entry$params)), + extraDistr::dbbinom(x, size = size, alpha = alpha, beta = beta) + ) + expect_equal( + as.numeric(call_dist(entry$p, x, entry$params)), + extraDistr::pbbinom(x, size = size, alpha = alpha, beta = beta) + ) +}) + +test_that("lognormal matches stats::lnorm", { + entry <- dist_registry_get("lognormal")[[1]] + x <- c(0.5, 1, 2, 4) + expect_equal( + call_dist(entry$d, x, entry$params), + dlnorm(x, meanlog = 0, sdlog = 1) + ) + expect_equal( + call_dist(entry$p, x, entry$params), + plnorm(x, meanlog = 0, sdlog = 1) + ) + p <- c(0.1, 0.5, 0.9) + expect_equal( + call_dist(entry$q, p, entry$params), + qlnorm(p, meanlog = 0, sdlog = 1) + ) +}) + +test_that("geometric equals nbinom with size = 1", { + entry <- dist_registry_get("geometric")[[1]] + mu <- entry$params$mu + x <- 0:12 + expect_equal( + call_dist(entry$d, x, entry$params), + dnbinom(x, mu = mu, size = 1) + ) + expect_equal( + call_dist(entry$p, x, entry$params), + pnbinom(x, mu = mu, size = 1) + ) +}) + +test_that("zi = 0 reduces zero_inflated_poisson to poisson", { + entry <- dist_registry_get("zero_inflated_poisson")[[1]] + lambda <- entry$params$lambda + x <- 0:10 + expect_equal( + dzero_inflated_poisson(x, lambda = lambda, zi = 0), + dpois(x, lambda = lambda) + ) + expect_equal( + pzero_inflated_poisson(x, lambda = lambda, zi = 0), + ppois(x, lambda = lambda) + ) + p <- c(0.1, 0.5, 0.9) + expect_equal( + qzero_inflated_poisson(p, lambda = lambda, zi = 0), + qpois(p, lambda = lambda) + ) +}) + +test_that("qhurdle_negbinomial recovers special cases", { + mu <- 4 + shape <- 2.5 + # hu = 0 => same as truncated-at-zero-removed nbinom quantile path via + # qhurdle; for p > 0 the positive part matches renormalized nbinom. + # hu = 1 => all mass at 0 + expect_equal( + qhurdle_negbinomial(c(0.1, 0.5, 0.9), mu = mu, shape = shape, hu = 1), + c(0, 0, 0) + ) + # hu small: values above 0 for p > hu + q <- qhurdle_negbinomial(c(0.05, 0.3, 0.8), mu = mu, shape = shape, hu = 0.1) + expect_equal(q[1], 0) + expect_true(all(q[2:3] > 0)) + expect_true(all(diff(q) >= 0)) +}) diff --git a/tests/testthat/tests.distributions_quantile_outputs.R b/tests/testthat/tests.distributions_quantile_outputs.R deleted file mode 100644 index 11f56d20f..000000000 --- a/tests/testthat/tests.distributions_quantile_outputs.R +++ /dev/null @@ -1,255 +0,0 @@ -context("Validation tests for new discrete quantile distributions") - -test_that("qbeta_binomial satisfies the discrete quantile definition", { - skip_if_not_installed("extraDistr") - - size <- 12 - mu <- 0.35 - phi <- 8 - p <- c(0.01, 0.1, 0.5, 0.85, 0.99) - - q <- brms:::qbeta_binomial(p, size = size, mu = mu, phi = phi) - F_q <- brms:::pbeta_binomial(q, size = size, mu = mu, phi = phi) - F_qm1 <- brms:::pbeta_binomial(q - 1, size = size, mu = mu, phi = phi) - - expect_true(all(F_q >= p)) - expect_true(all(F_qm1 < p)) - expect_true(all(q >= 0 & q <= size)) -}) - -test_that("qcom_poisson satisfies the discrete quantile definition", { - mu <- 2 - shape <- 0.8 - p <- c(0.01, 0.1, 0.5, 0.85, 0.99) - - q <- brms:::qcom_poisson(p, mu = mu, shape = shape) - F_q <- brms:::pcom_poisson(q, mu = mu, shape = shape) - F_qm1 <- brms:::pcom_poisson(q - 1, mu = mu, shape = shape) - - expect_true(all(F_q >= p)) - expect_true(all(ifelse(q > 0, F_qm1 < p, TRUE))) - expect_true(all(q >= 0)) -}) - -test_that("qcom_poisson reduces to qpois when shape is 1", { - mu <- 3 - p <- c(0.1, 0.5, 0.9) - expect_equal( - brms:::qcom_poisson(p, mu = mu, shape = 1), - qpois(p, lambda = mu) - ) -}) - -test_that("qhurdle_poisson satisfies the discrete quantile definition", { - lambda <- 2 - hu <- 0.2 - p <- c(0.01, 0.1, 0.5, 0.85, 0.99) - - q <- brms:::qhurdle_poisson(p, lambda = lambda, hu = hu) - F_q <- brms:::phurdle_poisson(q, lambda = lambda, hu = hu) - F_qm1 <- brms:::phurdle_poisson(q - 1, lambda = lambda, hu = hu) - - expect_true(all(F_q >= p)) - expect_true(all(ifelse(q > 0, F_qm1 < p, TRUE))) - expect_true(all(q >= 0)) -}) - -test_that("qzero_inflated_negbinomial satisfies the discrete quantile definition", { - mu <- 4 - shape <- 2.5 - zi <- 0.3 - p <- c(0.01, 0.1, 0.5, 0.85, 0.99) - - q <- brms:::qzero_inflated_negbinomial(p, mu = mu, shape = shape, zi = zi) - F_q <- brms:::pzero_inflated_negbinomial(q, mu = mu, shape = shape, zi = zi) - F_qm1 <- brms:::pzero_inflated_negbinomial(q - 1, mu = mu, shape = shape, zi = zi) - - expect_true(all(F_q >= p)) - expect_true(all(F_qm1 < p)) - expect_true(all(q >= 0)) -}) - -test_that("qordinal matches the ordinal CDF", { - set.seed(11) - ns <- 7 - nthres <- 3 - eta <- rnorm(ns) - thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) - disc <- rep(1, ns) - p <- c(0.05, 0.25, 0.5, 0.75, 0.95) - - for (fam in c("cumulative", "sratio", "cratio", "acat")) { - F_mat <- brms:::pordinal( - seq_len(nthres + 1), eta = eta, thres = thres, disc = disc, - family = fam, link = "logit" - ) - for (pj in p) { - qj <- brms:::qordinal( - pj, eta = eta, thres = thres, disc = disc, - family = fam, link = "logit" - ) - expect_length(qj, ns) - expect_true(all(qj >= 1 & qj <= nthres + 1)) - expect_true(all(F_mat[cbind(seq_len(ns), qj)] + 1e-10 >= pj)) - expect_true(all( - ifelse(qj > 1, F_mat[cbind(seq_len(ns), qj - 1)] < pj + 1e-10, TRUE) - )) - } - } -}) - -test_that("qcategorical matches the categorical CDF", { - set.seed(12) - ns <- 7 - ncat <- 4 - eta <- matrix(rnorm(ns * ncat), nrow = ns) - p <- c(0.05, 0.25, 0.5, 0.75, 0.95) - F_mat <- brms:::pcategorical(seq_len(ncat), eta = eta) - - for (pj in p) { - qj <- brms:::qcategorical(pj, eta = eta) - expect_length(qj, ns) - expect_true(all(qj >= 1 & qj <= ncat)) - expect_true(all(F_mat[cbind(seq_len(ns), qj)] + 1e-10 >= pj)) - expect_true(all( - ifelse(qj > 1, F_mat[cbind(seq_len(ns), qj - 1)] < pj + 1e-10, TRUE) - )) - } -}) - -test_that("qhurdle_cumulative matches the mixture CDF", { - set.seed(13) - ns <- 7 - nthres <- 3 - ncat <- nthres + 1 - eta <- rnorm(ns) - thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) - disc <- rep(1, ns) - hu <- rep(0.25, ns) - p <- c(0.05, 0.2, 0.25, 0.5, 0.9, 0.99) - - for (pj in p) { - qj <- brms:::qhurdle_cumulative( - pj, eta = eta, thres = thres, hu = hu, disc = disc, link = "logit" - ) - expect_length(qj, ns) - expect_true(all(qj >= 0 & qj <= ncat)) - F_q <- vapply(seq_len(ns), function(s) { - brms:::phurdle_cumulative( - qj[s], eta = eta[s], thres = thres[s, , drop = FALSE], - hu = hu[s], disc = disc[s], link = "logit" - ) - }, numeric(1)) - expect_true(all(F_q + 1e-10 >= pj)) - } - expect_equal( - brms:::qhurdle_cumulative( - 0.1, eta = eta, thres = thres, hu = hu, disc = disc, link = "logit" - ), - rep(0, ns) - ) -}) - -test_that("qzero_one_inflated_beta matches the mixture CDF", { - shape1 <- 2 - shape2 <- 3 - zoi <- 0.25 - coi <- 0.4 - p <- c(0.01, 0.1, 0.2, 0.5, 0.9, 0.95, 0.99) - p0 <- zoi * (1 - coi) - p1 <- zoi * coi - - q <- brms:::qzero_one_inflated_beta( - p, shape1 = shape1, shape2 = shape2, zoi = zoi, coi = coi - ) - expect_equal(q[p <= p0], rep(0, sum(p <= p0))) - expect_equal(q[p >= 1 - p1], rep(1, sum(p >= 1 - p1))) - expect_true(all(q[p > p0 & p < 1 - p1] > 0 & q[p > p0 & p < 1 - p1] < 1)) - expect_true(all(diff(q) >= 0)) - - F_q <- brms:::pzero_one_inflated_beta( - q, shape1 = shape1, shape2 = shape2, zoi = zoi, coi = coi - ) - expect_true(all(F_q + 1e-8 >= p)) -}) - -test_that("qzero_inflated_asym_laplace matches the mixture CDF", { - mu <- 0 - sigma <- 1 - quantile <- 0.5 - zi <- 0.3 - p <- c(0.01, 0.1, 0.3, 0.5, 0.65, 0.85, 0.99) - - q <- brms:::qzero_inflated_asym_laplace( - p, mu = mu, sigma = sigma, quantile = quantile, zi = zi - ) - F0_base <- brms:::pasym_laplace(0, mu = mu, sigma = sigma, quantile = quantile) - F0_minus <- (1 - zi) * F0_base - F0 <- zi + (1 - zi) * F0_base - - expect_true(all(q[p < F0_minus] < 0)) - expect_equal(q[p >= F0_minus & p <= F0], rep(0, sum(p >= F0_minus & p <= F0))) - expect_true(all(q[p > F0] > 0)) - expect_true(all(diff(q) >= 0)) - - F_q <- brms:::pzero_inflated_asym_laplace( - q, mu = mu, sigma = sigma, quantile = quantile, zi = zi - ) - expect_true(all(F_q + 1e-8 >= p)) -}) - -test_that("quantile functions are monotone in probability", { - p <- seq(0.01, 0.99, length.out = 50) - - q_bb <- brms:::qbeta_binomial(p, size = 20, mu = 0.45, phi = 6) - q_zinb <- brms:::qzero_inflated_negbinomial(p, mu = 5, shape = 2, zi = 0.25) - q_comp <- brms:::qcom_poisson(p, mu = 2, shape = 1.5) - - expect_true(all(diff(q_bb) >= 0)) - expect_true(all(diff(q_zinb) >= 0)) - expect_true(all(diff(q_comp) >= 0)) -}) - -test_that("quantile functions respect lower.tail and log.p", { - p_ref <- 0.2 - - q_bb_upper <- brms:::qbeta_binomial( - p_ref, size = 20, mu = 0.45, phi = 6, - lower.tail = FALSE, log.p = FALSE - ) - q_bb_ref <- brms:::qbeta_binomial( - 1 - p_ref, size = 20, mu = 0.45, phi = 6, - lower.tail = TRUE, log.p = FALSE - ) - expect_equal(q_bb_upper, q_bb_ref) - - q_zinb_log <- brms:::qzero_inflated_negbinomial( - log(p_ref), mu = 5, shape = 2, zi = 0.25, - lower.tail = TRUE, log.p = TRUE - ) - q_zinb_ref <- brms:::qzero_inflated_negbinomial( - p_ref, mu = 5, shape = 2, zi = 0.25, - lower.tail = TRUE, log.p = FALSE - ) - expect_equal(q_zinb_log, q_zinb_ref) - - q_comp_upper <- brms:::qcom_poisson( - p_ref, mu = 2, shape = 0.8, - lower.tail = FALSE, log.p = FALSE - ) - q_comp_lower <- brms:::qcom_poisson( - 1 - p_ref, mu = 2, shape = 0.8, - lower.tail = TRUE, log.p = FALSE - ) - expect_equal(q_comp_upper, q_comp_lower) - - q_comp_log <- brms:::qcom_poisson( - log(p_ref), mu = 2, shape = 0.8, - lower.tail = TRUE, log.p = TRUE - ) - q_comp_ref <- brms:::qcom_poisson( - p_ref, mu = 2, shape = 0.8, - lower.tail = TRUE, log.p = FALSE - ) - expect_equal(q_comp_log, q_comp_ref) -}) diff --git a/tests/testthat/tests.distributions_relations.R b/tests/testthat/tests.distributions_relations.R new file mode 100644 index 000000000..757939bed --- /dev/null +++ b/tests/testthat/tests.distributions_relations.R @@ -0,0 +1,60 @@ +context("Distribution validation: d/p/q/r relations") + +test_that("p/q inverses hold for families with p and q", { + for (entry in dist_active_entries(require_funs = c("p", "q"))) { + expect_pq_inverse(entry) + expect_qp_inverse(entry) + } +}) + +test_that("discrete PMF matches CDF differences", { + for (entry in dist_active_entries( + require_funs = c("d", "p"), + discrete_support = TRUE + )) { + expect_d_sums_to_p(entry) + } +}) + +test_that("continuous PDF matches finite-difference of CDF", { + for (entry in dist_active_entries(type = c("continuous", "circular"))) { + expect_pdf_matches_cdf_fd(entry) + } +}) + +test_that("densities integrate or sum to one", { + for (entry in dist_active_entries(require_funs = "d")) { + expect_integrates_to_one(entry) + } +}) + +test_that("log and lower.tail / log.p flags are consistent", { + for (entry in dist_active_entries()) { + expect_log_and_tail_flags(entry) + } +}) + +test_that("RNG moments and CDF fit for families with r()", { + skip_on_cran() + for (entry in dist_active_entries()) { + expect_moments_match(entry) + expect_rng_fits_cdf(entry) + } +}) + +test_that("truncation formulas match compute_* helpers", { + for (entry in dist_active_entries(truncation = TRUE)) { + if (isTRUE(entry$flags$discrete_support)) { + expect_truncated_cdf_density_quantile(entry, lb = 1, ub = 6) + } else { + qs <- as.numeric(call_dist(entry$q, c(0.2, 0.8), entry$params)) + expect_truncated_cdf_density_quantile(entry, lb = qs[1], ub = qs[2]) + } + } +}) + +test_that("zero-inflated and hurdle mixture formulas match baseline d/p", { + for (entry in dist_active_entries(has_baseline = TRUE)) { + expect_zi_hurdle_mixture(entry) + } +}) diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index bc11fa04a..ffe646fcd 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -440,382 +440,20 @@ test_that("posterior_predict_custom runs without errors", { expect_equal(length(brms:::posterior_predict_custom(sample(1:nobs, 1), prep)), ns) }) -make_prep_outcome <- function( - ns = 120, nobs = 8, seed = 1001, dpars = list(), data = list()) { - set.seed(seed) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- dpars - prep$data <- modifyList( - list(Y = rnorm(nobs), lb = rep(NULL, nobs), ub = rep(NULL, nobs)), - data - ) - prep -} - -make_prep_gaussian_outcome <- function(ns = 120, nobs = 8) { - make_prep_outcome( - ns = ns, nobs = nobs, seed = 1001, - dpars = list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rgamma(ns, shape = 4, rate = 3) - ) - ) -} - -make_prep_student_outcome <- function(ns = 120, nobs = 8) { - make_prep_outcome( - ns = ns, nobs = nobs, seed = 1002, - dpars = list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rgamma(ns, shape = 4, rate = 3), - nu = rgamma(ns, shape = 6, rate = 1) + 2 - ) - ) -} - -make_prep_positive_outcome <- function(ns = 120, nobs = 8) { - make_prep_outcome( - ns = ns, nobs = nobs, seed = 1003, - dpars = list( - mu = matrix(exp(rnorm(ns * nobs, mean = 0.2, sd = 0.4)), ncol = nobs), - sigma = rgamma(ns, shape = 4, rate = 3), - beta = rgamma(ns, shape = 4, rate = 3), - shape = rgamma(ns, shape = 6, rate = 2) + 0.5, - ndt = runif(ns, min = 0, max = 0.5), - alpha = rnorm(ns), - nu = rgamma(ns, shape = 4, rate = 1) + 2, - xi = rnorm(ns, sd = 0.3), - quantile = runif(ns, min = 0.2, max = 0.8), - phi = rgamma(ns, shape = 5, rate = 1), - kappa = rgamma(ns, shape = 2, rate = 1), - zi = rbeta(ns, 1.5, 5) - ), - data = list(Y = rgamma(nobs, shape = 2, rate = 1)) - ) -} - -make_prep_beta_outcome <- function(ns = 140, nobs = 9) { - make_prep_outcome( - ns = ns, nobs = nobs, seed = 1004, - dpars = list( - mu = matrix(plogis(rnorm(ns * nobs)), ncol = nobs), - phi = rgamma(ns, shape = 5, rate = 1), - kappa = rgamma(ns, shape = 2, rate = 1), - zi = rbeta(ns, 1.5, 5), - zoi = rbeta(ns, 1.5, 5), - coi = rbeta(ns, 2, 6) - ), - data = list(Y = rbeta(nobs, shape1 = 2, shape2 = 3)) - ) -} - -make_prep_outcome_discrete <- function(ns = 160, nobs = 12, seed = 1005) { - set.seed(seed) - trials <- sample(10:30, nobs, replace = TRUE) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(plogis(rnorm(ns * nobs)), ncol = nobs), - phi = rgamma(ns, shape = 5, rate = 1), - shape = rgamma(ns, shape = 4, rate = 1), - sigma = rgamma(ns, shape = 3, rate = 2), - zi = rbeta(ns, 1.5, 5) - ) - prep$data <- list( - Y = rpois(nobs, lambda = 5), - trials = trials, - lb = rep(NULL, nobs), - ub = rep(NULL, nobs) - ) - prep -} - -expect_outcome_random <- function(family_fun, prep, i, support = c(-Inf, Inf), - check_integer = FALSE, seed = 1234) { - set.seed(seed) - random_outcome <- family_fun(i, prep = prep) - - testthat::expect_length(random_outcome, prep$ndraws) - testthat::expect_true(all(is.finite(random_outcome))) - - if (is.finite(support[1])) { - testthat::expect_true(all(random_outcome >= support[1])) - } - if (is.finite(support[2])) { - testthat::expect_true(all(random_outcome <= support[2])) - } - if (isTRUE(check_integer)) { - testthat::expect_true(all(abs(random_outcome - round(random_outcome)) < 1e-8)) - } -} - -expect_outcome_modes <- function(family_fun, prep, i, q_ref, p_ref, - support = c(-Inf, Inf), - check_integer = FALSE) { - expect_outcome_random( - family_fun = family_fun, prep = prep, i = i, support = support, - check_integer = check_integer - ) - - prob <- family_fun(i, prep = prep, output = "probability", q = q_ref) - pit <- family_fun(i, prep = prep, output = "pit", q = q_ref) - dens <- family_fun(i, prep = prep, output = "density", q = q_ref) - q <- family_fun(i, prep = prep, output = "quantile", p = p_ref) - - for (x in list(prob, pit, dens, q)) { - testthat::expect_type(x, "double") - testthat::expect_length(x, prep$ndraws) - testthat::expect_true(all(is.finite(x) | is.na(x))) - } -} - -test_that("posterior_predict outcome argument works for continuous families", { - i <- 3 - - family_specs <- list( - gaussian = list( - fun = brms:::posterior_predict_gaussian, q_ref = 0.25, p_ref = 0.73, - support = c(-Inf, Inf), prep = make_prep_gaussian_outcome() - ), - student = list( - fun = brms:::posterior_predict_student, q_ref = 0.25, p_ref = 0.73, - support = c(-Inf, Inf), prep = make_prep_student_outcome() - ), - lognormal = list( - fun = brms:::posterior_predict_lognormal, q_ref = 1.2, p_ref = 0.73, - support = c(0, Inf), prep = make_prep_positive_outcome() - ), - gamma = list( - fun = brms:::posterior_predict_gamma, q_ref = 1.2, p_ref = 0.73, - support = c(0, Inf), prep = make_prep_positive_outcome() - ), - weibull = list( - fun = brms:::posterior_predict_weibull, q_ref = 1.2, p_ref = 0.73, - support = c(0, Inf), prep = make_prep_positive_outcome() - ), - exponential = list( - fun = brms:::posterior_predict_exponential, q_ref = 1.2, p_ref = 0.73, - support = c(0, Inf), prep = make_prep_positive_outcome() - ), - shifted_lognormal = list( - fun = brms:::posterior_predict_shifted_lognormal, q_ref = 1.2, p_ref = 0.73, - support = c(0, Inf), prep = make_prep_positive_outcome() - ), - skew_normal = list( - fun = brms:::posterior_predict_skew_normal, q_ref = 0.25, p_ref = 0.73, - support = c(-Inf, Inf), prep = make_prep_positive_outcome() - ), - frechet = list( - fun = brms:::posterior_predict_frechet, q_ref = 1.2, p_ref = 0.73, - support = c(0, Inf), prep = make_prep_positive_outcome() - ), - exgaussian = list( - fun = brms:::posterior_predict_exgaussian, q_ref = 1.2, p_ref = 0.73, - support = c(-Inf, Inf), prep = make_prep_positive_outcome() - ), - inverse_gaussian = list( - fun = brms:::posterior_predict_inverse.gaussian, q_ref = 1.2, p_ref = 0.73, - support = c(0, Inf), prep = make_prep_positive_outcome() - ), - gen_extreme_value = list( - fun = brms:::posterior_predict_gen_extreme_value, q_ref = 0.25, p_ref = 0.73, - support = c(-Inf, Inf), prep = make_prep_positive_outcome() - ), - asym_laplace = list( - fun = brms:::posterior_predict_asym_laplace, q_ref = 0.25, p_ref = 0.73, - support = c(-Inf, Inf), prep = make_prep_positive_outcome() - ), - zero_inflated_asym_laplace = list( - fun = brms:::posterior_predict_zero_inflated_asym_laplace, - q_ref = 0.25, p_ref = 0.73, - support = c(-Inf, Inf), prep = make_prep_positive_outcome() - ), - xbeta = list( - fun = brms:::posterior_predict_xbeta, q_ref = 0.4, p_ref = 0.73, - support = c(0, 1), prep = make_prep_beta_outcome(), requires = "betareg" - ), - beta = list( - fun = brms:::posterior_predict_beta, q_ref = 0.4, p_ref = 0.73, - support = c(0, 1), prep = make_prep_beta_outcome() - ), - zero_inflated_beta = list( - fun = brms:::posterior_predict_zero_inflated_beta, q_ref = 0.4, p_ref = 0.8, - support = c(0, 1), prep = make_prep_beta_outcome() - ), - zero_one_inflated_beta = list( - fun = brms:::posterior_predict_zero_one_inflated_beta, q_ref = 0.4, p_ref = 0.8, - support = c(0, 1), prep = make_prep_beta_outcome() - ) - ) - - for (spec in family_specs) { - if (!is.null(spec$requires)) { - skip_if_not_installed(spec$requires) - } - expect_outcome_modes( - family_fun = spec$fun, - prep = spec$prep, - i = i, - q_ref = spec$q_ref, - p_ref = spec$p_ref, - support = spec$support - ) - } -}) - -test_that("posterior_predict outcome argument works for discrete families", { - i <- 4 - prep <- make_prep_outcome_discrete() - - family_specs <- list( - bernoulli = list(fun = brms:::posterior_predict_bernoulli, q_ref = 1), - binomial = list(fun = brms:::posterior_predict_binomial, q_ref = 3), - beta_binomial = list(fun = brms:::posterior_predict_beta_binomial, q_ref = 3), - poisson = list(fun = brms:::posterior_predict_poisson, q_ref = 3), - negbinomial = list(fun = brms:::posterior_predict_negbinomial, q_ref = 3), - negbinomial2 = list(fun = brms:::posterior_predict_negbinomial2, q_ref = 3), - geometric = list(fun = brms:::posterior_predict_geometric, q_ref = 3), - discrete_weibull = list( - fun = brms:::posterior_predict_discrete_weibull, q_ref = 3 - ), - com_poisson = list(fun = brms:::posterior_predict_com_poisson, q_ref = 3), - zero_inflated_poisson = list( - fun = brms:::posterior_predict_zero_inflated_poisson, q_ref = 3 - ), - zero_inflated_binomial = list( - fun = brms:::posterior_predict_zero_inflated_binomial, q_ref = 3 - ), - zero_inflated_beta_binomial = list( - fun = brms:::posterior_predict_zero_inflated_beta_binomial, q_ref = 3 - ), - zero_inflated_negbinomial = list( - fun = brms:::posterior_predict_zero_inflated_negbinomial, q_ref = 3 - ) - ) - - for (spec in family_specs) { - if (!is.null(spec$requires)) { - skip_if_not_installed(spec$requires) - } - expect_outcome_modes( - family_fun = spec$fun, - prep = prep, - i = i, - q_ref = spec$q_ref, - p_ref = 0.81, - support = c(0, Inf), - check_integer = TRUE - ) - } -}) - -test_that("posterior_predict output argument works for ordinal families", { - ns <- 80 - nobs <- 6 - nthres <- 3 - ncat <- nthres + 1 - set.seed(1010) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - disc = rexp(ns) - ) - prep$thres$thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) - prep$data <- list( - Y = rep(1:ncat, length.out = nobs), - ncat = ncat, - lb = rep(NULL, nobs), - ub = rep(NULL, nobs) - ) - prep$family$link <- "logit" - i <- 2 - - for (fam in c("cumulative", "sratio", "cratio", "acat")) { - prep$family$family <- fam - expect_outcome_modes( - family_fun = brms:::posterior_predict_ordinal, - prep = prep, - i = i, - q_ref = 2, - p_ref = 0.7, - support = c(1, ncat), - check_integer = TRUE - ) - } -}) - -test_that("posterior_predict output argument works for categorical", { - set.seed(1011) - ns <- 80 - nobs <- 6 - ncat <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu1 = matrix(rnorm(ns * nobs, 0, 0.1), ncol = nobs), - mu2 = matrix(rnorm(ns * nobs, 0, 0.1), ncol = nobs) - ) - prep$data <- list( - Y = rep(1:ncat, length.out = nobs), - ncat = ncat, - lb = rep(NULL, nobs), - ub = rep(NULL, nobs) - ) - prep$family <- categorical() - prep$refcat <- 1 - i <- 2 - - expect_outcome_modes( - family_fun = brms:::posterior_predict_categorical, - prep = prep, - i = i, - q_ref = 2, - p_ref = 0.7, - support = c(1, ncat), - check_integer = TRUE - ) -}) - -test_that("posterior_predict output argument works for hurdle_cumulative", { - set.seed(1012) - ns <- 80 - nobs <- 6 - nthres <- 3 - ncat <- nthres + 1 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - disc = rexp(ns), - hu = rbeta(ns, 1.5, 5) - ) - prep$thres$thres <- matrix(rep(c(-1, 0, 1), each = ns), nrow = ns) - prep$data <- list( - Y = rep(0:ncat, length.out = nobs), - ncat = ncat, - lb = rep(NULL, nobs), - ub = rep(NULL, nobs) - ) - prep$family <- hurdle_cumulative() - i <- 2 - - expect_outcome_modes( - family_fun = brms:::posterior_predict_hurdle_cumulative, - prep = prep, - i = i, - q_ref = 2, - p_ref = 0.7, - support = c(0, ncat), - check_integer = TRUE - ) -}) +# --------------------------------------------------------------------------- +# Tests for the posterior_predict() output API +# (probability / pit / density / quantile, plus compute_cdf helpers) +# --------------------------------------------------------------------------- test_that("compute_cdf returns correct CDF for non-truncated distributions", { # Non-truncated, non-randomized: raw CDF F(q) q <- 3 - out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, + out <- brms:::compute_cdf(q = q, distribution = "pois", lb = NULL, ub = NULL, randomized = FALSE, lambda = 5) expect_equal(out, ppois(q, lambda = 5)) q <- 2 - out <- brms:::compute_cdf(q = q, dist = "binom", lb = NULL, ub = NULL, + out <- brms:::compute_cdf(q = q, distribution = "binom", lb = NULL, ub = NULL, randomized = FALSE, size = 10, prob = 0.5) expect_equal(out, pbinom(q, size = 10, prob = 0.5)) }) @@ -827,7 +465,7 @@ test_that("compute_cdf with randomized = TRUE returns value in [F(q-1), F(q)]", Fq <- ppois(q, lambda = 3) Fqm1 <- ppois(q - 1, lambda = 3) - out <- brms:::compute_cdf(q = q, dist = "pois", lb = NULL, ub = NULL, + out <- brms:::compute_cdf(q = q, distribution = "pois", lb = NULL, ub = NULL, randomized = TRUE, lambda = 3) expect_true(out >= Fqm1) expect_true(out <= Fq) @@ -843,30 +481,21 @@ valid range", { Fq <- (ppois(q, lambda = 5) - ppois(lb, lambda = 5)) / denom Fqm1 <- (ppois(q - 1, lambda = 5) - ppois(lb, lambda = 5)) / denom - out <- brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, + out <- brms:::compute_cdf(q = q, distribution = "pois", lb = lb, ub = ub, randomized = TRUE, lambda = 5) expect_true(out >= Fqm1) expect_true(out <= Fq) expect_true(out >= 0 && out <= 1) }) -test_that("compute_cdf handles zero denominator (lb == ub) without unexpected -behaviour", { - q <- 3 - lb <- 1 - ub <- 1 - - out <- tryCatch( - brms:::compute_cdf(q = q, dist = "pois", lb = lb, ub = ub, - randomized = FALSE, lambda = 2), - error = function(e) structure(list(error = TRUE, message = e$message)) +test_that("compute_cdf errors when truncation bounds yield a zero denominator", { + expect_error( + brms:::compute_cdf( + q = 3, distribution = "pois", lb = 1, ub = 1, + randomized = FALSE, lambda = 2 + ), + "Division by zero" ) - - if (is.list(out) && isTRUE(out$error)) { - expect_true(grepl("zero|denom|divide|trunc", out$message, ignore.case = TRUE)) - } else { - expect_true(is.nan(out) || is.na(out)) - } }) @@ -927,4 +556,74 @@ test_that("posterior_predict forwards lower.tail and log.p correctly", { expect_equal(p_upper, 1 - p_lower) expect_equal(log_lower, log(p_lower)) expect_equal(log_upper, log(p_upper)) -}) \ No newline at end of file +}) + + +test_that("posterior_predict errors for unsupported non-random outputs", { + # helper rejects random-only families; random and supported families are allowed + expect_error( + brms:::validate_pp_output_support("wiener", "probability"), + "not yet implemented for family 'wiener'" + ) + expect_silent(brms:::validate_pp_output_support("wiener", "random")) + expect_silent(brms:::validate_pp_output_support("gaussian", "probability")) + + # public path errors before silently returning random draws + prep <- structure( + list( + family = list(fun = "wiener", family = "wiener"), + ndraws = 2, nobs = 1, + dpars = list(), data = list() + ), + class = "brmsprep" + ) + expect_error( + posterior_predict(prep, output = "probability"), + "not yet implemented for family 'wiener'" + ) +}) + +test_that("posterior_predict outputs match analytical d/p/q for registered families", { + entries <- pp_test_entries() + expect_gt(length(entries), 0L) + for (entry in entries) { + expect_pp_output_matches_dist(entry, i = 1L) + } +}) + +test_that("PP PIT contract: continuous identity, discrete randomized", { + entries <- pp_test_entries() + expect_gt(length(entries), 0L) + for (entry in entries) { + expect_pp_pit_contract(entry, i = 1L, seed = 99) + } +}) + +test_that("PP truncation matches truncated d/p/q formulas", { + entries <- pp_test_entries(truncation = TRUE) + expect_gt(length(entries), 0L) + for (entry in entries) { + expect_pp_truncation(entry, i = 1L) + } +}) + +test_that("PP respects lower.tail, log.p, and log flags", { + entries <- pp_test_entries() + expect_gt(length(entries), 0L) + for (entry in entries) { + expect_pp_log_tail_flags(entry, i = 1L) + } +}) + +test_that("randomized PIT is reproducible with the same seed", { + entry <- dist_registry_get("pois")[[1]] + prep <- entry$prep_builder(ns = 50, nobs = 3, seed = 1) + withr::local_seed(123) + pit1 <- entry$pp_fun(1L, prep = prep, output = "pit", q = 3) + withr::local_seed(123) + pit2 <- entry$pp_fun(1L, prep = prep, output = "pit", q = 3) + expect_equal(pit1, pit2) + withr::local_seed(456) + pit3 <- entry$pp_fun(1L, prep = prep, output = "pit", q = 3) + expect_true(any(pit1 != pit3)) +}) From a5518414fda1594ed5fbcc7c47f8bc0ebdd7cac0 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 14:24:55 +0300 Subject: [PATCH 60/63] chore: remove withr and vdiffr dependency --- tests/testthat/helper-distributions.R | 16 ++++++++-------- tests/testthat/helper-posterior-predict.R | 6 +++--- tests/testthat/tests.distributions_analytical.R | 6 +++--- tests/testthat/tests.posterior_predict.R | 6 +++--- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/tests/testthat/helper-distributions.R b/tests/testthat/helper-distributions.R index 201d2e985..7fcee7a11 100644 --- a/tests/testthat/helper-distributions.R +++ b/tests/testthat/helper-distributions.R @@ -199,7 +199,7 @@ call_dist <- function(fun, x, params, ...) { make_prep_location <- function(ns = 25, nobs = 4, mu = 0, sigma = 1, extra = list(), Y = NULL, seed = NULL) { - if (!is.null(seed)) withr::local_seed(seed) + if (!is.null(seed)) set.seed(seed) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- c( list( @@ -215,7 +215,7 @@ make_prep_location <- function(ns = 25, nobs = 4, mu = 0, sigma = 1, make_prep_positive <- function(ns = 25, nobs = 4, mu = 1, shape = 2, extra = list(), Y = NULL, seed = NULL) { - if (!is.null(seed)) withr::local_seed(seed) + if (!is.null(seed)) set.seed(seed) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- c( list( @@ -234,7 +234,7 @@ make_prep_positive <- function(ns = 25, nobs = 4, mu = 1, shape = 2, make_prep_count <- function(ns = 25, nobs = 4, mu = 3, shape = 2, trials = 10, zi = 0.2, hu = 0.2, extra = list(), Y = NULL, seed = NULL) { - if (!is.null(seed)) withr::local_seed(seed) + if (!is.null(seed)) set.seed(seed) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- c( list( @@ -256,7 +256,7 @@ make_prep_count <- function(ns = 25, nobs = 4, mu = 3, shape = 2, make_prep_beta_mix <- function(ns = 25, nobs = 4, mu = 0.4, phi = 5, zoi = 0.2, coi = 0.4, Y = NULL, seed = NULL) { - if (!is.null(seed)) withr::local_seed(seed) + if (!is.null(seed)) set.seed(seed) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(mu, nrow = ns, ncol = nobs), @@ -272,7 +272,7 @@ make_prep_beta_mix <- function(ns = 25, nobs = 4, mu = 0.4, phi = 5, make_prep_ordinal <- function(ns = 25, nobs = 4, nthres = 3, family = "cumulative", link = "logit", hu = NULL, Y = NULL, seed = NULL) { - if (!is.null(seed)) withr::local_seed(seed) + if (!is.null(seed)) set.seed(seed) ncat <- nthres + 1L prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( @@ -299,7 +299,7 @@ make_prep_ordinal <- function(ns = 25, nobs = 4, nthres = 3, make_prep_categorical <- function(ns = 25, nobs = 4, ncat = 3, Y = NULL, seed = NULL) { - if (!is.null(seed)) withr::local_seed(seed) + if (!is.null(seed)) set.seed(seed) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") # reference category inserted by posterior_predict_categorical mu_names <- paste0("mu", seq_len(ncat - 1L)) @@ -1622,7 +1622,7 @@ expect_moments_match <- function(entry, n = 8000, tol = 0.15, seed = 1) { if (!has_fun(entry, "r") || isTRUE(entry$flags$skip_moments)) { return(invisible(TRUE)) } - withr::local_seed(seed) + set.seed(seed) draws <- as.numeric(do.call(entry$r, c(list(n), entry$params))) # approximate mean via quantile grid when closed form unknown ps <- seq(0.001, 0.999, length.out = 500) @@ -1638,7 +1638,7 @@ expect_rng_fits_cdf <- function(entry, n = 4000, tol = 0.08, seed = 2) { isTRUE(entry$flags$skip_rng_cdf)) { return(invisible(TRUE)) } - withr::local_seed(seed) + set.seed(seed) draws <- as.numeric(do.call(entry$r, c(list(n), entry$params))) u <- as.numeric(call_dist(entry$p, draws, entry$params)) # continuous: PIT ~ U(0,1); discrete: not uniform — compare ECDF at probes diff --git a/tests/testthat/helper-posterior-predict.R b/tests/testthat/helper-posterior-predict.R index 012f2cd30..ddd08a7ba 100644 --- a/tests/testthat/helper-posterior-predict.R +++ b/tests/testthat/helper-posterior-predict.R @@ -64,7 +64,7 @@ expect_pp_output_matches_dist <- function(entry, i = 1L, tol = 1e-7, } if (has_output(entry, "random")) { - withr::local_seed(seed) + set.seed(seed) got <- pp(i, prep = prep, output = "random") testthat::expect_length(got, prep$ndraws) testthat::expect_true(all(is.finite(got))) @@ -209,9 +209,9 @@ expect_pp_pit_contract <- function(entry, i = 1L, seed = 99, tol = 1e-8) { info = paste(entry$name, "PIT ≡ probability")) } else { # discrete / ordinal: randomized PIT = F(q-1) + V*(F(q)-F(q-1)) - withr::local_seed(seed) + set.seed(seed) pit <- pp(i, prep = prep, output = "pit", q = q) - withr::local_seed(seed) + set.seed(seed) args <- get_pp_dist_args(entry, prep, i) expected <- do.call( brms:::compute_cdf, diff --git a/tests/testthat/tests.distributions_analytical.R b/tests/testthat/tests.distributions_analytical.R index d8876a018..c345847d8 100644 --- a/tests/testthat/tests.distributions_analytical.R +++ b/tests/testthat/tests.distributions_analytical.R @@ -105,7 +105,7 @@ test_that("qzero_inflated_asym_laplace matches mixture CDF regions", { }) test_that("qordinal matches the ordinal CDF", { - withr::local_seed(11) + set.seed(11) ns <- 7 nthres <- 3 eta <- rnorm(ns) @@ -133,7 +133,7 @@ test_that("qordinal matches the ordinal CDF", { }) test_that("qcategorical matches the categorical CDF", { - withr::local_seed(12) + set.seed(12) ns <- 7 ncat <- 4 eta <- matrix(rnorm(ns * ncat), nrow = ns) @@ -151,7 +151,7 @@ test_that("qcategorical matches the categorical CDF", { }) test_that("qhurdle_cumulative matches the mixture CDF", { - withr::local_seed(13) + set.seed(13) ns <- 7 nthres <- 3 ncat <- nthres + 1 diff --git a/tests/testthat/tests.posterior_predict.R b/tests/testthat/tests.posterior_predict.R index ffe646fcd..9c37e13a5 100644 --- a/tests/testthat/tests.posterior_predict.R +++ b/tests/testthat/tests.posterior_predict.R @@ -618,12 +618,12 @@ test_that("PP respects lower.tail, log.p, and log flags", { test_that("randomized PIT is reproducible with the same seed", { entry <- dist_registry_get("pois")[[1]] prep <- entry$prep_builder(ns = 50, nobs = 3, seed = 1) - withr::local_seed(123) + set.seed(123) pit1 <- entry$pp_fun(1L, prep = prep, output = "pit", q = 3) - withr::local_seed(123) + set.seed(123) pit2 <- entry$pp_fun(1L, prep = prep, output = "pit", q = 3) expect_equal(pit1, pit2) - withr::local_seed(456) + set.seed(456) pit3 <- entry$pp_fun(1L, prep = prep, output = "pit", q = 3) expect_true(any(pit1 != pit3)) }) From 7242ff3308c2f80c57bfcca60d8ae1c4e2ae5cb0 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 14:25:16 +0300 Subject: [PATCH 61/63] docs: update cheatsheet-vignette --- .../brms_distribution_output_cheatsheet.Rmd | 903 ++++++++++++++---- 1 file changed, 718 insertions(+), 185 deletions(-) diff --git a/vignettes/brms_distribution_output_cheatsheet.Rmd b/vignettes/brms_distribution_output_cheatsheet.Rmd index 68df05ab7..45f4ea13e 100644 --- a/vignettes/brms_distribution_output_cheatsheet.Rmd +++ b/vignettes/brms_distribution_output_cheatsheet.Rmd @@ -10,7 +10,7 @@ vignette: > %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") + EVAL: TRUE #!r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r setup, include=FALSE} @@ -33,11 +33,17 @@ devtools::load_all() if (!requireNamespace("extraDistr", quietly = TRUE)) { stop("Package 'extraDistr' is required to evaluate this vignette.") } +has_betareg <- requireNamespace("betareg", quietly = TRUE) +has_mnormt <- requireNamespace("mnormt", quietly = TRUE) theme_set(theme_minimal(base_size = 9)) set.seed(4026) +# Defined here so knitr can resolve fig.height even when later chunks +# are skipped (eval = FALSE on CRAN). +n_cols <- 5L +fig_height <- 10.5 ``` -This cheatsheet summarizes the distribution families that currently support all +This cheatsheet summarizes distribution families that currently support **all** `posterior_predict()` output modes: - `random` @@ -46,124 +52,49 @@ This cheatsheet summarizes the distribution families that currently support all - `density` - `quantile` -## Supported families +It is not an exhaustive list of every family that accepts the `output` +argument: some families only support `random`, and a few do not support +posterior predictive draws at all (see [Not fully supported](#not-fully-supported)). -```{r support-table} -support <- data.frame( - family = c( - "gaussian", "student", "binomial", "beta_binomial", - "poisson", "negbinomial", "negbinomial2", "zero_inflated_negbinomial" - ), - distribution_backend = c( - "norm", "student_t", "binom", "beta_binomial", - "pois", "nbinom", "nbinom", "zero_inflated_negbinomial" - ), - random = "\u2713", - probability = "\u2713", - pit = "\u2713", - density = "\u2713", - quantile = "\u2713", - stringsAsFactors = FALSE -) -knitr::kable(support, align = "l") -``` - -## Mathematical details - -Let \(Y\) be the posterior predictive variable for one posterior draw \(s\), with -distribution \(F_s\) and density/mass \(f_s\). For each observation index \(i\), -`posterior_predict()` returns one value per draw \(s = 1, \dots, S\). - -### 1) `output = "random"` - -Draw -\[ -\tilde y_s \sim F_s. -\] -If truncation bounds are active (\(L, U\)), sampling is from the truncated -distribution: -\[ -F_{s,\text{tr}}(y) = \frac{F_s(y) - F_s(L)}{F_s(U) - F_s(L)}, \quad L \le y \le U. -\] - -### 2) `output = "probability"` - -For a queried value \(q\), return the (possibly truncated) CDF: -\[ -p_s(q) = F_s(q) -\] -or, with truncation, -\[ -p_s(q) = \frac{F_s(q) - F_s(L)}{F_s(U) - F_s(L)}. -\] -With `lower.tail = FALSE`, return \(1 - p_s(q)\). With `log.p = TRUE`, return -\(\log p_s(q)\). - -### 3) `output = "pit"` +Ordinal families (`cumulative`, `sratio`, `cratio`, `acat`) route through the +shared `posterior_predict_ordinal()` backend. -- Continuous case: PIT equals the CDF value, -\[ -\text{PIT}_s = F_s(y_i). -\] -- Discrete case: randomized PIT (to avoid spikes), -\[ -\text{PIT}_s = F_s(y_i - 1) + V_s \left[F_s(y_i) - F_s(y_i - 1)\right], \quad -V_s \sim \text{Uniform}(0,1). -\] - -### 4) `output = "density"` - -For a queried value \(q\), return -\[ -d_s(q) = f_s(q) -\] -or with truncation, -\[ -d_s(q) = \frac{f_s(q)}{F_s(U) - F_s(L)} \mathbf{1}\{L \le q \le U\}. -\] -With `log = TRUE`, return \(\log d_s(q)\). - -For discrete distributions, this corresponds to PMF values and satisfies -\[ -d_s(k) = F_s(k) - F_s(k-1). -\] - -### 5) `output = "quantile"` - -For queried probability \(p\), return -\[ -q_s(p) = F_s^{-1}(p). -\] -With truncation, the internally transformed probability is -\[ -p_s^\star = p \left[F_s(U) - F_s(L)\right] + F_s(L), -\] -and then -\[ -q_s(p) = F_s^{-1}(p_s^\star). -\] -`lower.tail` and `log.p` are first converted to standard probabilities before -applying these formulas. - -### Zero-inflated and hurdle families +```{r data-helpers, include=FALSE} +# Inverse-CDF RNG for families without an exported r*() helper +r_from_q <- function(qfun, n, ...) { + qfun(runif(n), ...) +} -For zero-inflated families (parameter \(\pi\), baseline distribution \(G\)): -\[ -P(Y=0) = \pi + (1-\pi)G(0), \qquad -P(Y=y>0) = (1-\pi)G(y). -\] +ord_thres <- matrix(c(-1, 0, 1), nrow = 1) +cat_eta <- matrix(c(0, 0.4, -0.2), nrow = 1) + +# hurdle_cumulative q/r treat length(p)/rows as draws, not query points +q_hurdle_cumulative_curve <- function(p, hu = 0.25) { + vapply( + p, + function(pi) { + qhurdle_cumulative( + pi, eta = 0, thres = ord_thres, hu = hu, link = "logit" + ) + }, + numeric(1) + ) +} -For hurdle families (parameter \(h\), baseline distribution \(G\)): -\[ -P(Y=0) = h, \qquad -P(Y=y>0) = (1-h)\frac{G(y)}{1-G(0)}. -\] +r_hurdle_cumulative_n <- function(n, hu = 0.25) { + eta <- rep(0, n) + thres <- ord_thres[rep(1, n), , drop = FALSE] + rhurdle_cumulative( + n, eta = eta, thres = thres, hu = rep(hu, n), link = "logit" + ) +} -These definitions induce the corresponding CDF, density/mass, and quantile -computations used by `probability`, `density`, and `quantile`. +r_categorical_n <- function(n) { + rcategorical(n, eta = cat_eta[rep(1, n), , drop = FALSE]) +} -```{r data-helpers, include=FALSE} specs <- list( + # ---- continuous ---- list( family = "gaussian", type = "continuous", x = seq(-4, 4, length.out = 200), p = seq(0.01, 0.99, length.out = 200), @@ -180,6 +111,116 @@ specs <- list( qf = function(p) qstudent_t(p, df = 7, mu = 0, sigma = 1), r = function(n) rstudent_t(n, df = 7, mu = 0, sigma = 1) ), + list( + family = "lognormal", type = "continuous", x = seq(0.05, 8, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dlnorm(x, meanlog = 0, sdlog = 1), + cdf = function(q) plnorm(q, meanlog = 0, sdlog = 1), + qf = function(p) qlnorm(p, meanlog = 0, sdlog = 1), + r = function(n) rlnorm(n, meanlog = 0, sdlog = 1) + ), + list( + family = "shifted_lognormal", type = "continuous", + x = seq(0.35, 8, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dshifted_lnorm(x, meanlog = 0, sdlog = 1, shift = 0.3), + cdf = function(q) pshifted_lnorm(q, meanlog = 0, sdlog = 1, shift = 0.3), + qf = function(p) qshifted_lnorm(p, meanlog = 0, sdlog = 1, shift = 0.3), + r = function(n) rshifted_lnorm(n, meanlog = 0, sdlog = 1, shift = 0.3) + ), + list( + family = "exponential", type = "continuous", x = seq(0.01, 6, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dexp(x, rate = 1), + cdf = function(q) pexp(q, rate = 1), + qf = function(p) qexp(p, rate = 1), + r = function(n) rexp(n, rate = 1) + ), + list( + family = "gamma", type = "continuous", x = seq(0.01, 10, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dgamma(x, shape = 2, scale = 1), + cdf = function(q) pgamma(q, shape = 2, scale = 1), + qf = function(p) qgamma(p, shape = 2, scale = 1), + r = function(n) rgamma(n, shape = 2, scale = 1) + ), + list( + family = "weibull", type = "continuous", x = seq(0.01, 4, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dweibull(x, shape = 2, scale = 1), + cdf = function(q) pweibull(q, shape = 2, scale = 1), + qf = function(p) qweibull(p, shape = 2, scale = 1), + r = function(n) rweibull(n, shape = 2, scale = 1) + ), + list( + family = "frechet", type = "continuous", x = seq(0.2, 6, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dfrechet(x, scale = 1, shape = 3), + cdf = function(q) pfrechet(q, scale = 1, shape = 3), + qf = function(p) qfrechet(p, scale = 1, shape = 3), + r = function(n) rfrechet(n, scale = 1, shape = 3) + ), + list( + family = "gen_extreme_value", type = "continuous", + x = seq(-3, 6, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dgen_extreme_value(x, mu = 0, sigma = 1, xi = 0.1), + cdf = function(q) pgen_extreme_value(q, mu = 0, sigma = 1, xi = 0.1), + qf = function(p) qgen_extreme_value(p, mu = 0, sigma = 1, xi = 0.1), + r = function(n) rgen_extreme_value(n, mu = 0, sigma = 1, xi = 0.1) + ), + list( + family = "inverse.gaussian", type = "continuous", + x = seq(0.05, 4, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dinv_gaussian(x, mu = 1, shape = 2), + cdf = function(q) pinv_gaussian(q, mu = 1, shape = 2), + qf = function(p) qinv_gaussian(p, mu = 1, shape = 2), + r = function(n) rinv_gaussian(n, mu = 1, shape = 2) + ), + list( + family = "exgaussian", type = "continuous", x = seq(-2, 8, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dexgaussian(x, mu = 0, sigma = 1, beta = 1), + cdf = function(q) pexgaussian(q, mu = 0, sigma = 1, beta = 1), + qf = function(p) qexgaussian(p, mu = 0, sigma = 1, beta = 1), + r = function(n) rexgaussian(n, mu = 0, sigma = 1, beta = 1) + ), + list( + family = "asym_laplace", type = "continuous", + x = seq(-4, 4, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dasym_laplace(x, mu = 0, sigma = 1, quantile = 0.5), + cdf = function(q) pasym_laplace(q, mu = 0, sigma = 1, quantile = 0.5), + qf = function(p) qasym_laplace(p, mu = 0, sigma = 1, quantile = 0.5), + r = function(n) rasym_laplace(n, mu = 0, sigma = 1, quantile = 0.5) + ), + list( + family = "beta", type = "continuous", x = seq(0.01, 0.99, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dbeta(x, shape1 = 2, shape2 = 3), + cdf = function(q) pbeta(q, shape1 = 2, shape2 = 3), + qf = function(p) qbeta(p, shape1 = 2, shape2 = 3), + r = function(n) rbeta(n, shape1 = 2, shape2 = 3) + ), + list( + family = "von_mises", type = "continuous", + x = seq(-pi, pi, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dvon_mises(x, mu = 0, kappa = 2), + cdf = function(q) pvon_mises(q, mu = 0, kappa = 2), + qf = function(p) qvon_mises(p, mu = 0, kappa = 2), + r = function(n) rvon_mises(n, mu = 0, kappa = 2) + ), + # ---- discrete ---- + list( + family = "bernoulli", type = "discrete", x = 0:1, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dbinom(x, size = 1, prob = 0.4), + cdf = function(q) pbinom(q, size = 1, prob = 0.4), + qf = function(p) qbinom(p, size = 1, prob = 0.4), + r = function(n) rbinom(n, size = 1, prob = 0.4) + ), list( family = "binomial", type = "discrete", x = 0:20, p = seq(0.01, 0.99, length.out = 120), @@ -220,42 +261,359 @@ specs <- list( qf = function(p) qnbinom(p, mu = 5, size = 1 / 0.6), r = function(n) rnbinom(n, mu = 5, size = 1 / 0.6) ), + list( + family = "geometric", type = "discrete", x = 0:20, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dnbinom(x, mu = 3, size = 1), + cdf = function(q) pnbinom(q, mu = 3, size = 1), + qf = function(p) qnbinom(p, mu = 3, size = 1), + r = function(n) rnbinom(n, mu = 3, size = 1) + ), + list( + family = "discrete_weibull", type = "discrete", x = 0:15, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) ddiscrete_weibull(x, mu = 0.7, shape = 1.5), + cdf = function(q) pdiscrete_weibull(q, mu = 0.7, shape = 1.5), + qf = function(p) qdiscrete_weibull(p, mu = 0.7, shape = 1.5), + r = function(n) rdiscrete_weibull(n, mu = 0.7, shape = 1.5) + ), + list( + family = "com_poisson", type = "discrete", x = 0:12, + p = seq(0.01, 0.99, length.out = 80), + d = function(x) dcom_poisson(x, mu = 2, shape = 0.8), + cdf = function(q) pcom_poisson(q, mu = 2, shape = 0.8), + qf = function(p) qcom_poisson(p, mu = 2, shape = 0.8), + r = function(n) rcom_poisson(n, mu = 2, shape = 0.8) + ), + # ---- hurdle ---- + list( + family = "hurdle_poisson", type = "discrete", x = 0:18, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dhurdle_poisson(x, lambda = 5, hu = 0.25), + cdf = function(q) phurdle_poisson(q, lambda = 5, hu = 0.25), + qf = function(p) qhurdle_poisson(p, lambda = 5, hu = 0.25), + r = function(n) r_from_q(qhurdle_poisson, n, lambda = 5, hu = 0.25) + ), + list( + family = "hurdle_negbinomial", type = "discrete", x = 0:24, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dhurdle_negbinomial(x, mu = 5, shape = 2, hu = 0.25), + cdf = function(q) phurdle_negbinomial(q, mu = 5, shape = 2, hu = 0.25), + qf = function(p) qhurdle_negbinomial(p, mu = 5, shape = 2, hu = 0.25), + r = function(n) { + r_from_q(qhurdle_negbinomial, n, mu = 5, shape = 2, hu = 0.25) + } + ), + list( + family = "hurdle_gamma", type = "mixture", x = seq(0, 10, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dhurdle_gamma(x, shape = 2, scale = 1, hu = 0.25), + cdf = function(q) phurdle_gamma(q, shape = 2, scale = 1, hu = 0.25), + qf = function(p) qhurdle_gamma(p, shape = 2, scale = 1, hu = 0.25), + r = function(n) r_from_q(qhurdle_gamma, n, shape = 2, scale = 1, hu = 0.25) + ), + list( + family = "hurdle_lognormal", type = "mixture", + x = seq(0, 8, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dhurdle_lognormal(x, mu = 0, sigma = 1, hu = 0.25), + cdf = function(q) phurdle_lognormal(q, mu = 0, sigma = 1, hu = 0.25), + qf = function(p) qhurdle_lognormal(p, mu = 0, sigma = 1, hu = 0.25), + r = function(n) r_from_q(qhurdle_lognormal, n, mu = 0, sigma = 1, hu = 0.25) + ), + list( + family = "hurdle_cumulative", type = "discrete", x = 0:4, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) { + as.numeric(dhurdle_cumulative( + x, eta = 0, thres = ord_thres, hu = 0.25, link = "logit" + )) + }, + cdf = function(q) { + as.numeric(phurdle_cumulative( + q, eta = 0, thres = ord_thres, hu = 0.25, link = "logit" + )) + }, + qf = function(p) q_hurdle_cumulative_curve(p, hu = 0.25), + r = function(n) r_hurdle_cumulative_n(n, hu = 0.25) + ), + # ---- zero-inflated ---- + list( + family = "zero_inflated_poisson", type = "discrete", x = 0:18, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dzero_inflated_poisson(x, lambda = 5, zi = 0.25), + cdf = function(q) pzero_inflated_poisson(q, lambda = 5, zi = 0.25), + qf = function(p) qzero_inflated_poisson(p, lambda = 5, zi = 0.25), + r = function(n) r_from_q(qzero_inflated_poisson, n, lambda = 5, zi = 0.25) + ), list( family = "zero_inflated_negbinomial", type = "discrete", x = 0:24, p = seq(0.01, 0.99, length.out = 120), d = function(x) dzero_inflated_negbinomial(x, mu = 5, shape = 2, zi = 0.25), - cdf = function(q) pzero_inflated_negbinomial(q, mu = 5, shape = 2, zi = 0.25), - qf = function(p) qzero_inflated_negbinomial(p, mu = 5, shape = 2, zi = 0.25), + cdf = function(q) { + pzero_inflated_negbinomial(q, mu = 5, shape = 2, zi = 0.25) + }, + qf = function(p) { + qzero_inflated_negbinomial(p, mu = 5, shape = 2, zi = 0.25) + }, r = function(n) { - base <- rnbinom(n, mu = 5, size = 2) - is_zi <- runif(n) < 0.25 - base[is_zi] <- 0 - base + r_from_q(qzero_inflated_negbinomial, n, mu = 5, shape = 2, zi = 0.25) + } + ), + list( + family = "zero_inflated_binomial", type = "discrete", x = 0:20, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) dzero_inflated_binomial(x, size = 20, prob = 0.4, zi = 0.2), + cdf = function(q) { + pzero_inflated_binomial(q, size = 20, prob = 0.4, zi = 0.2) + }, + qf = function(p) { + qzero_inflated_binomial(p, size = 20, prob = 0.4, zi = 0.2) + }, + r = function(n) { + r_from_q(qzero_inflated_binomial, n, size = 20, prob = 0.4, zi = 0.2) + } + ), + list( + family = "zero_inflated_beta_binomial", type = "discrete", x = 0:20, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) { + dzero_inflated_beta_binomial(x, size = 20, mu = 0.4, phi = 8, zi = 0.2) + }, + cdf = function(q) { + pzero_inflated_beta_binomial(q, size = 20, mu = 0.4, phi = 8, zi = 0.2) + }, + qf = function(p) { + qzero_inflated_beta_binomial(p, size = 20, mu = 0.4, phi = 8, zi = 0.2) + }, + r = function(n) { + r_from_q( + qzero_inflated_beta_binomial, n, + size = 20, mu = 0.4, phi = 8, zi = 0.2 + ) + } + ), + list( + family = "zero_inflated_beta", type = "mixture", + x = seq(0, 1, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.25), + cdf = function(q) pzero_inflated_beta(q, shape1 = 2, shape2 = 3, zi = 0.25), + qf = function(p) qzero_inflated_beta(p, shape1 = 2, shape2 = 3, zi = 0.25), + r = function(n) { + r_from_q(qzero_inflated_beta, n, shape1 = 2, shape2 = 3, zi = 0.25) + } + ), + list( + family = "zero_inflated_asym_laplace", type = "mixture", + x = seq(-4, 4, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) { + dzero_inflated_asym_laplace( + x, mu = 0, sigma = 1, quantile = 0.5, zi = 0.3 + ) + }, + cdf = function(q) { + pzero_inflated_asym_laplace( + q, mu = 0, sigma = 1, quantile = 0.5, zi = 0.3 + ) + }, + qf = function(p) { + qzero_inflated_asym_laplace( + p, mu = 0, sigma = 1, quantile = 0.5, zi = 0.3 + ) + }, + r = function(n) { + r_from_q( + qzero_inflated_asym_laplace, n, + mu = 0, sigma = 1, quantile = 0.5, zi = 0.3 + ) + } + ), + list( + family = "zero_one_inflated_beta", type = "mixture", + x = seq(0, 1, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) { + dzero_one_inflated_beta( + x, shape1 = 2, shape2 = 3, zoi = 0.25, coi = 0.4 + ) + }, + cdf = function(q) { + pzero_one_inflated_beta( + q, shape1 = 2, shape2 = 3, zoi = 0.25, coi = 0.4 + ) + }, + qf = function(p) { + qzero_one_inflated_beta( + p, shape1 = 2, shape2 = 3, zoi = 0.25, coi = 0.4 + ) + }, + r = function(n) { + r_from_q( + qzero_one_inflated_beta, n, + shape1 = 2, shape2 = 3, zoi = 0.25, coi = 0.4 + ) } ) ) +# ---- ordinal / categorical ---- +ordinal_specs <- lapply(c("cumulative", "sratio", "cratio", "acat"), function(fam) { + force(fam) + list( + family = fam, type = "discrete", x = 1:4, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) { + as.numeric(dordinal( + x, eta = 0, thres = ord_thres, family = fam, link = "logit" + )) + }, + cdf = function(q) { + as.numeric(pordinal( + q, eta = 0, thres = ord_thres, family = fam, link = "logit" + )) + }, + qf = function(p) { + as.numeric(qordinal( + p, eta = 0, thres = ord_thres, family = fam, link = "logit" + )) + }, + r = function(n) { + as.numeric(rordinal( + n, eta = 0, thres = ord_thres, family = fam, link = "logit" + )) + } + ) +}) + +categorical_spec <- list( + family = "categorical", type = "discrete", x = 1:3, + p = seq(0.01, 0.99, length.out = 120), + d = function(x) as.numeric(dcategorical(x, eta = cat_eta)), + cdf = function(q) as.numeric(pcategorical(q, eta = cat_eta)), + qf = function(p) as.numeric(qcategorical(p, eta = cat_eta)), + r = function(n) as.numeric(r_categorical_n(n)) +) + +specs <- c(specs, ordinal_specs, list(categorical_spec)) + +if (has_mnormt) { + skew_spec <- list( + family = "skew_normal", type = "continuous", + x = seq(-3, 5, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dskew_normal(x, mu = 0, sigma = 1, alpha = 2), + cdf = function(q) pskew_normal(q, mu = 0, sigma = 1, alpha = 2), + qf = function(p) qskew_normal(p, mu = 0, sigma = 1, alpha = 2), + r = function(n) rskew_normal(n, mu = 0, sigma = 1, alpha = 2) + ) + shifted_idx <- match("shifted_lognormal", vapply(specs, `[[`, "", "family")) + specs <- append(specs, list(skew_spec), after = shifted_idx) +} + +if (has_betareg) { + xbeta_spec <- list( + family = "xbeta", type = "continuous", + x = seq(0.01, 0.99, length.out = 200), + p = seq(0.01, 0.99, length.out = 200), + d = function(x) dxbeta(x, mu = 0.5, phi = 5, nu = 1), + cdf = function(q) pxbeta(q, mu = 0.5, phi = 5, nu = 1), + qf = function(p) qxbeta(p, mu = 0.5, phi = 5, nu = 1), + r = function(n) rxbeta(n, mu = 0.5, phi = 5, nu = 1) + ) + beta_idx <- match("beta", vapply(specs, `[[`, "", "family")) + specs <- append(specs, list(xbeta_spec), after = beta_idx) +} + + +# Family -> compute_*/predict_* distribution backend name +family_backends <- c( + gaussian = "norm", + student = "student_t", + lognormal = "lnorm", + shifted_lognormal = "shifted_lnorm", + skew_normal = "skew_normal", + exponential = "exp", + gamma = "gamma", + weibull = "weibull", + frechet = "frechet", + gen_extreme_value = "gen_extreme_value", + "inverse.gaussian" = "inv_gaussian", + exgaussian = "exgaussian", + asym_laplace = "asym_laplace", + beta = "beta", + xbeta = "xbeta", + von_mises = "von_mises", + bernoulli = "binom", + binomial = "binom", + beta_binomial = "beta_binomial", + poisson = "pois", + negbinomial = "nbinom", + negbinomial2 = "nbinom", + geometric = "nbinom", + discrete_weibull = "discrete_weibull", + com_poisson = "com_poisson", + hurdle_poisson = "hurdle_poisson", + hurdle_negbinomial = "hurdle_negbinomial", + hurdle_gamma = "hurdle_gamma", + hurdle_lognormal = "hurdle_lognormal", + hurdle_cumulative = "hurdle_cumulative", + zero_inflated_poisson = "zero_inflated_poisson", + zero_inflated_negbinomial = "zero_inflated_negbinomial", + zero_inflated_binomial = "zero_inflated_binomial", + zero_inflated_beta_binomial = "zero_inflated_beta_binomial", + zero_inflated_beta = "zero_inflated_beta", + zero_inflated_asym_laplace = "zero_inflated_asym_laplace", + zero_one_inflated_beta = "zero_one_inflated_beta", + cumulative = "ordinal", + sratio = "ordinal", + cratio = "ordinal", + acat = "ordinal", + categorical = "categorical" +) + +fams <- vapply(specs, `[[`, character(1), "family") +missing_backend <- setdiff(fams, names(family_backends)) +if (length(missing_backend)) { + stop("Missing family_backends for: ", paste(missing_backend, collapse = ", ")) +} +tick <- "✓" +support <- data.frame( + family = fams, + distribution_backend = unname(family_backends[fams]), + random = tick, + probability = tick, + pit = tick, + density = tick, + quantile = tick, + stringsAsFactors = FALSE +) + make_output_data <- function(spec) { density_df <- data.frame( family = spec$family, type = spec$type, x = spec$x, - y = spec$d(spec$x) + y = as.numeric(spec$d(spec$x)) ) + # continuous mixture densities may be Inf at atoms; drop for plotting + density_df$y[!is.finite(density_df$y)] <- NA_real_ + probability_df <- data.frame( family = spec$family, type = spec$type, x = spec$x, - y = spec$cdf(spec$x) + y = as.numeric(spec$cdf(spec$x)) ) quantile_df <- data.frame( family = spec$family, type = spec$type, x = spec$p, - y = spec$qf(spec$p) + y = as.numeric(spec$qf(spec$p)) ) - draws <- spec$r(500) + draws <- as.numeric(spec$r(500)) ecdf_fun <- ecdf(draws) random_df <- data.frame( family = spec$family, @@ -264,12 +622,16 @@ make_output_data <- function(spec) { y = ecdf_fun(spec$x) ) - pit_draws <- spec$r(400) + pit_draws <- as.numeric(spec$r(400)) if (identical(spec$type, "continuous")) { - pit <- spec$cdf(pit_draws) + pit <- as.numeric(spec$cdf(pit_draws)) + } else if (identical(spec$type, "mixture")) { + # continuous mixtures with atoms: use CDF (atoms appear as spikes) + pit <- as.numeric(spec$cdf(pit_draws)) } else { u <- runif(length(pit_draws)) - pit <- spec$cdf(pit_draws - 1) + u * (spec$cdf(pit_draws) - spec$cdf(pit_draws - 1)) + pit <- as.numeric(spec$cdf(pit_draws - 1)) + + u * (as.numeric(spec$cdf(pit_draws)) - as.numeric(spec$cdf(pit_draws - 1))) } pit <- pmax(0, pmin(1, pit)) pit_hist <- hist(pit, breaks = seq(0, 1, by = 0.1), plot = FALSE) @@ -295,101 +657,272 @@ quantile_data <- do.call(rbind, lapply(all_data, `[[`, "quantile")) random_data <- do.call(rbind, lapply(all_data, `[[`, "random")) pit_data <- do.call(rbind, lapply(all_data, `[[`, "pit")) +n_families <- length(specs) +fig_height <- max(4.2, 1.15 * ceiling(n_families / n_cols)) + panel_theme <- theme( - strip.text = element_text(size = 8), + strip.text = element_text(size = 7), axis.title = element_blank(), panel.grid.minor = element_blank() ) + +# Shared facet + labels wrapper; `layers` is a list of geoms. +thumb_plot <- function(layers, title, ylab, scales = "free_x", xlab = NULL) { + ggplot() + + layers + + facet_wrap(~ family, scales = scales, ncol = n_cols) + + labs(title = title, x = xlab, y = ylab) + + panel_theme +} +``` + + +## Supported families (full five-mode support) + +The table is generated from the same family specs used for the thumbnails +below (optional families appear only when their Suggested packages are +installed: `skew_normal` needs `mnormt`, `xbeta` needs `betareg`). + +```{r support-table} +knitr::kable(support, align = "l") ``` +## Not fully supported + +These families accept `posterior_predict()` but do **not** implement all five +output modes (or cannot draw from the predictive at all): + +| Category | Families | Supported `output` | +|----------|----------|--------------------| +| Multivariate / time / spatial / residual correlation | `gaussian_mv`, `student_mv`, `gaussian_time`, `student_time`, `gaussian_lagsar`, `student_lagsar`, `gaussian_errorsar`, `student_errorsar`, `gaussian_fcor`, `student_fcor` | `random` only | +| Diffusion | `wiener` | `random` only | +| Compositional / multinomial | `multinomial`, `dirichlet_multinomial`, `dirichlet`, `dirichlet2`, `logistic_normal` | `random` only | +| Mixtures of families | `mixture` | `random` only | +| Survival (no predictive draws) | `cox` | none (`posterior_predict()` errors) | +| User-defined | `custom` | `random` by default; other modes only if the custom family implements them | + +Truncation note: even among fully supported families, truncated **random** +sampling is not implemented for several hurdle families (they warn and ignore +bounds for `output = "random"`). + +## Mathematical details + +Let \(Y\) be the posterior predictive variable for one posterior draw \(s\), with +distribution \(F_s\) and density/mass \(f_s\). For each observation index \(i\), +`posterior_predict()` returns one value per draw \(s = 1, \dots, S\). + +### 1) `output = "random"` + +Draw +\[ +\tilde y_s \sim F_s. +\] +If truncation bounds are active (\(L, U\)), sampling is from the truncated +distribution: +\[ +F_{s,\text{tr}}(y) = \frac{F_s(y) - F_s(L)}{F_s(U) - F_s(L)}, \quad L \le y \le U. +\] + +### 2) `output = "probability"` + +For a queried value \(q\), return the (possibly truncated) CDF: +\[ +p_s(q) = F_s(q) +\] +or, with truncation, +\[ +p_s(q) = \frac{F_s(q) - F_s(L)}{F_s(U) - F_s(L)}. +\] +With `lower.tail = FALSE`, return \(1 - p_s(q)\). With `log.p = TRUE`, return +\(\log p_s(q)\). + +### 3) `output = "pit"` + +- Continuous case: PIT equals the CDF value, +\[ +\text{PIT}_s = F_s(y_i). +\] +- Discrete case: randomized PIT (to avoid spikes), +\[ +\text{PIT}_s = F_s(y_i - 1) + V_s \left[F_s(y_i) - F_s(y_i - 1)\right], \quad +V_s \sim \text{Uniform}(0,1). +\] + +### 4) `output = "density"` + +For a queried value \(q\), return +\[ +d_s(q) = f_s(q) +\] +or with truncation, +\[ +d_s(q) = \frac{f_s(q)}{F_s(U) - F_s(L)} \mathbf{1}\{L \le q \le U\}. +\] +With `log = TRUE`, return \(\log d_s(q)\). + +For discrete distributions, this corresponds to PMF values and satisfies +\[ +d_s(k) = F_s(k) - F_s(k-1). +\] + +### 5) `output = "quantile"` + +For queried probability \(p\), return +\[ +q_s(p) = F_s^{-1}(p). +\] +With truncation, the internally transformed probability is +\[ +p_s^\star = p \left[F_s(U) - F_s(L)\right] + F_s(L), +\] +and then +\[ +q_s(p) = F_s^{-1}(p_s^\star). +\] +`lower.tail` and `log.p` are first converted to standard probabilities before +applying these formulas. + +### Zero-inflated and hurdle families + +For zero-inflated families (parameter \(\pi\), baseline distribution \(G\)): +\[ +P(Y=0) = \pi + (1-\pi)G(0), \qquad +P(Y=y>0) = (1-\pi)G(y). +\] + +For hurdle families (parameter \(h\), baseline distribution \(G\)): +\[ +P(Y=0) = h, \qquad +P(Y=y>0) = (1-h)\frac{G(y)}{1-G(0)}. +\] + +These definitions induce the corresponding CDF, density/mass, and quantile +computations used by `probability`, `density`, and `quantile`. + ## Random output Empirical CDF of random draws (`output = "random"`). -```{r random-plot, fig.width=9, fig.height=4.2} -ggplot(random_data, aes(x = x, y = y)) + - geom_line(linewidth = 0.4, color = "#2c7fb8") + - facet_wrap(~ family, scales = "free_x", ncol = 4) + - labs(title = "Random output (empirical CDF thumbnails)", y = "ECDF") + - panel_theme +```{r random-plot, fig.width=9, fig.height=fig_height} +thumb_plot( + list( + geom_point( + data = subset(random_data, type != "discrete"), + aes(x = x, y = y), + size = 0.4, color = "#2c7fb8" + ), + geom_point( + data = subset(random_data, type == "discrete"), + aes(x = x, y = y), + size = 1.1, color = "#2c7fb8" + ) + ), + title = "Random output (empirical CDF thumbnails)", + ylab = "ECDF" +) ``` ## Probability output CDF values (`output = "probability"`). -```{r probability-plot, fig.width=9, fig.height=4.2} -ggplot(probability_data, aes(x = x, y = y)) + - geom_line( - data = subset(probability_data, type == "continuous"), - linewidth = 0.4, color = "#1b9e77" - ) + - geom_step( - data = subset(probability_data, type == "discrete"), - linewidth = 0.4, color = "#1b9e77" - ) + - facet_wrap(~ family, scales = "free_x", ncol = 4) + - labs(title = "Probability output (CDF thumbnails)", y = "P(X <= x)") + - panel_theme +```{r probability-plot, fig.width=9, fig.height=fig_height} +thumb_plot( + list( + geom_line( + data = subset(probability_data, type %in% c("continuous", "mixture")), + aes(x = x, y = y), + linewidth = 0.4, color = "#1b9e77" + ), + geom_step( + data = subset(probability_data, type == "discrete"), + aes(x = x, y = y), + linewidth = 0.4, color = "#1b9e77" + ) + ), + title = "Probability output (CDF thumbnails)", + ylab = "P(X <= x)" +) ``` ## PIT output PIT histogram (`output = "pit"`). For calibrated models, these are near-uniform. -```{r pit-plot, fig.width=9, fig.height=4.2} -ggplot(pit_data, aes(x = midpoint, y = density)) + - geom_col(width = 0.085, fill = "#7570b3", alpha = 0.75) + - geom_hline(yintercept = 1, linewidth = 0.25, linetype = "dashed") + - facet_wrap(~ family, ncol = 4) + - scale_x_continuous(limits = c(0, 1), breaks = c(0, 0.5, 1)) + - labs(title = "PIT output (thumbnail histograms)", y = "Density") + - panel_theme +```{r pit-plot, fig.width=9, fig.height=fig_height} +thumb_plot( + list( + geom_col( + data = pit_data, aes(x = midpoint, y = density), + width = 0.085, fill = "#7570b3", alpha = 0.75 + ), + geom_hline(yintercept = 1, linewidth = 0.25, linetype = "dashed"), + scale_x_continuous(limits = c(0, 1), breaks = c(0, 0.5, 1)) + ), + title = "PIT output (thumbnail histograms)", + ylab = "Density", + scales = "fixed" +) ``` ## Density output -PDF/PMF values (`output = "density"`). - -```{r density-plot, fig.width=9, fig.height=4.2} -ggplot() + - geom_line( - data = subset(density_data, type == "continuous"), - aes(x = x, y = y), - linewidth = 0.45, color = "#d95f02" - ) + - geom_col( - data = subset(density_data, type == "discrete"), - aes(x = x, y = y), - width = 0.85, fill = "#d95f02", alpha = 0.7 - ) + - facet_wrap(~ family, scales = "free_x", ncol = 4) + - labs(title = "Density output (PDF/PMF thumbnails)", y = "Density / Mass") + - panel_theme +PDF/PMF values (`output = "density"`). Point masses of mixture families are +omitted from the continuous density curves. + +```{r density-plot, fig.width=9, fig.height=fig_height} +thumb_plot( + list( + geom_line( + data = subset(density_data, type %in% c("continuous", "mixture")), + aes(x = x, y = y), + linewidth = 0.45, color = "#d95f02", na.rm = TRUE + ), + geom_col( + data = subset(density_data, type == "discrete"), + aes(x = x, y = y), + width = 0.85, fill = "#d95f02", alpha = 0.7 + ) + ), + title = "Density output (PDF/PMF thumbnails)", + ylab = "Density / Mass", + scales = "free" +) ``` ## Quantile output Inverse CDF values (`output = "quantile"`). -```{r quantile-plot, fig.width=9, fig.height=4.2} -ggplot(quantile_data, aes(x = x, y = y)) + - geom_line( - data = subset(quantile_data, type == "continuous"), - linewidth = 0.4, color = "#e7298a" - ) + - geom_step( - data = subset(quantile_data, type == "discrete"), - linewidth = 0.4, color = "#e7298a" - ) + - facet_wrap(~ family, scales = "free_y", ncol = 4) + - labs(title = "Quantile output (inverse-CDF thumbnails)", x = "p", y = "Q(p)") + - panel_theme +```{r quantile-plot, fig.width=9, fig.height=fig_height} +thumb_plot( + list( + geom_line( + data = subset(quantile_data, type %in% c("continuous", "mixture")), + aes(x = x, y = y), + linewidth = 0.4, color = "#e7298a" + ), + geom_step( + data = subset(quantile_data, type == "discrete"), + aes(x = x, y = y), + linewidth = 0.4, color = "#e7298a" + ) + ), + title = "Quantile output (inverse-CDF thumbnails)", + ylab = "Q(p)", + xlab = "p", + scales = "free_y" +) ``` ## Notes - Continuous families have `probability == pit`. -- Discrete families use randomized PIT to avoid spikes. +- Discrete and ordinal families use randomized PIT to avoid spikes. +- Mixture families with point masses (hurdle continuous, zero-/zero-one-inflated + beta and asymmetric Laplace) have atoms that are handled in the CDF/quantile + helpers; density thumbnails show only the continuous component. - The parameter values here are illustrative; the output shape changes with posterior draws in real model fits. +- `skew_normal` thumbnails require Suggested package `mnormt`; `xbeta` + thumbnails require Suggested package `betareg`. From 58bf2ac1dddbc00d24afa4479e909aadf36d9f8f Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 15:20:58 +0300 Subject: [PATCH 62/63] feat: add random draw support for hurdle family --- DESCRIPTION | 2 +- NAMESPACE | 4 ++ R/distributions.R | 31 +++++++- R/posterior_predict.R | 72 +++++-------------- man/Hurdle.Rd | 17 ++++- man/brms-package.Rd | 5 ++ man/posterior_predict.brmsfit.Rd | 4 +- man/predict.brmsfit.Rd | 4 +- man/psis.brmsfit.Rd | 2 +- notes/pr-summary.md | 53 ++++++++++++++ tests/testthat/helper-distributions.R | 23 +++--- tests/testthat/helper-posterior-predict.R | 10 +++ tests/testthat/tests.distributions.R | 14 ++++ .../brms_distribution_output_cheatsheet.Rmd | 16 ++--- 14 files changed, 175 insertions(+), 82 deletions(-) create mode 100644 notes/pr-summary.md diff --git a/DESCRIPTION b/DESCRIPTION index 6f21ceef3..b30081bfa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -113,4 +113,4 @@ SystemRequirements: pngquant VignetteBuilder: knitr, R.rsp -RoxygenNote: 7.3.3 +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index ec4eaa746..31d3d4548 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -608,6 +608,10 @@ export(rexgaussian) export(rfrechet) export(rgen_extreme_value) export(rhat) +export(rhurdle_gamma) +export(rhurdle_lognormal) +export(rhurdle_negbinomial) +export(rhurdle_poisson) export(rinv_gaussian) export(rlogistic_normal) export(rmulti_normal) diff --git a/R/distributions.R b/R/distributions.R index d0c49ae77..ad7f1255c 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2327,7 +2327,8 @@ qzero_one_inflated_beta <- function(p, shape1, shape2, zoi, coi, #' Hurdle Distributions #' -#' Density and distribution functions for hurdle distributions. +#' Density, distribution function, quantile function and random generation +#' for hurdle distributions. #' #' @name Hurdle #' @@ -2368,6 +2369,13 @@ qhurdle_poisson <- function(p, lambda, hu, lower.tail = TRUE, .qhurdle(p, "pois", hu, pars, lower.tail, log.p, type = "int") } +#' @rdname Hurdle +#' @export +rhurdle_poisson <- function(n, lambda, hu) { + n <- check_n_rdist(n, lambda, hu) + qhurdle_poisson(runif(n), lambda = lambda, hu = hu) +} + #' @rdname Hurdle #' @export dhurdle_negbinomial <- function(x, mu, shape, hu, log = FALSE) { @@ -2391,6 +2399,13 @@ qhurdle_negbinomial <- function(p, mu, shape, hu, lower.tail = TRUE, .qhurdle(p, "nbinom", hu, pars, lower.tail, log.p, type = "int") } +#' @rdname Hurdle +#' @export +rhurdle_negbinomial <- function(n, mu, shape, hu) { + n <- check_n_rdist(n, mu, shape, hu) + qhurdle_negbinomial(runif(n), mu = mu, shape = shape, hu = hu) +} + #' @rdname Hurdle #' @export dhurdle_gamma <- function(x, shape, scale, hu, log = FALSE) { @@ -2414,6 +2429,13 @@ qhurdle_gamma <- function(p, shape, scale, hu, lower.tail = TRUE, .qhurdle(p, "gamma", hu, pars, lower.tail, log.p, type = "real") } +#' @rdname Hurdle +#' @export +rhurdle_gamma <- function(n, shape, scale, hu) { + n <- check_n_rdist(n, shape, scale, hu) + qhurdle_gamma(runif(n), shape = shape, scale = scale, hu = hu) +} + #' @rdname Hurdle #' @export dhurdle_lognormal <- function(x, mu, sigma, hu, log = FALSE) { @@ -2437,6 +2459,13 @@ qhurdle_lognormal <- function(p, mu, sigma, hu, lower.tail = TRUE, .qhurdle(p, "lnorm", hu, pars, lower.tail, log.p, type = "real") } +#' @rdname Hurdle +#' @export +rhurdle_lognormal <- function(n, mu, sigma, hu) { + n <- check_n_rdist(n, mu, sigma, hu) + qhurdle_lognormal(runif(n), mu = mu, sigma = sigma, hu = hu) +} + # density of the hurdle-cumulative distribution # categories: 0 = hurdle, 1..ncat = cumulative ordinal categories # @param x category indices diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 07c63838b..4f004b746 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -805,20 +805,10 @@ posterior_predict_hurdle_poisson <- function(i, prep, output = "random", hu <- get_dpar(prep, "hu", i = i) lambda <- get_dpar(prep, "mu", i = i) lambda <- multiply_dpar_rate_denom(lambda, prep, i = i) - - if (output == "random") { - if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { - warning2( - "Truncated random sampling is not yet implemented for hurdle_poisson." - ) - } - qhurdle_poisson(runif(prep$ndraws), lambda = lambda, hu = hu) - } else { - predict_discrete_helper( - i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_poisson", lambda = lambda, hu = hu, ... - ) - } + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_poisson", lambda = lambda, hu = hu, ... + ) } posterior_predict_hurdle_negbinomial <- function(i, prep, output = "random", @@ -827,20 +817,10 @@ posterior_predict_hurdle_negbinomial <- function(i, prep, output = "random", mu <- get_dpar(prep, "mu", i = i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- get_dpar(prep, "shape", i = i) - - if (output == "random") { - if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { - warning2( - "Truncated random sampling is not yet implemented for hurdle_negbinomial." - ) - } - qhurdle_negbinomial(runif(prep$ndraws), mu = mu, shape = shape, hu = hu) - } else { - predict_discrete_helper( - i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_negbinomial", mu = mu, shape = shape, hu = hu, ... - ) - } + predict_discrete_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_negbinomial", mu = mu, shape = shape, hu = hu, ... + ) } posterior_predict_hurdle_gamma <- function(i, prep, output = "random", @@ -848,20 +828,10 @@ posterior_predict_hurdle_gamma <- function(i, prep, output = "random", hu <- get_dpar(prep, "hu", i = i) shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / shape - - if (output == "random") { - if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { - warning2( - "Truncated random sampling is not yet implemented for hurdle_gamma." - ) - } - qhurdle_gamma(runif(prep$ndraws), shape = shape, scale = scale, hu = hu) - } else { - predict_continuous_helper( - i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_gamma", shape = shape, scale = scale, hu = hu, ... - ) - } + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_gamma", shape = shape, scale = scale, hu = hu, ... + ) } posterior_predict_hurdle_lognormal <- function(i, prep, output = "random", @@ -869,20 +839,10 @@ posterior_predict_hurdle_lognormal <- function(i, prep, output = "random", hu <- get_dpar(prep, "hu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) - - if (output == "random") { - if (!is.null(prep$data$lb[i]) || !is.null(prep$data$ub[i])) { - warning2( - "Truncated random sampling is not yet implemented for hurdle_lognormal." - ) - } - qhurdle_lognormal(runif(prep$ndraws), mu = mu, sigma = sigma, hu = hu) - } else { - predict_continuous_helper( - i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_lognormal", mu = mu, sigma = sigma, hu = hu, ... - ) - } + predict_continuous_helper( + i = i, prep = prep, output = output, ntrys = ntrys, + dist = "hurdle_lognormal", mu = mu, sigma = sigma, hu = hu, ... + ) } posterior_predict_hurdle_cumulative <- function(i, prep, output = "random", diff --git a/man/Hurdle.Rd b/man/Hurdle.Rd index e60230c11..e318a2d95 100644 --- a/man/Hurdle.Rd +++ b/man/Hurdle.Rd @@ -5,15 +5,19 @@ \alias{dhurdle_poisson} \alias{phurdle_poisson} \alias{qhurdle_poisson} +\alias{rhurdle_poisson} \alias{dhurdle_negbinomial} \alias{phurdle_negbinomial} \alias{qhurdle_negbinomial} +\alias{rhurdle_negbinomial} \alias{dhurdle_gamma} \alias{phurdle_gamma} \alias{qhurdle_gamma} +\alias{rhurdle_gamma} \alias{dhurdle_lognormal} \alias{phurdle_lognormal} \alias{qhurdle_lognormal} +\alias{rhurdle_lognormal} \title{Hurdle Distributions} \usage{ dhurdle_poisson(x, lambda, hu, log = FALSE) @@ -22,23 +26,31 @@ phurdle_poisson(q, lambda, hu, lower.tail = TRUE, log.p = FALSE) qhurdle_poisson(p, lambda, hu, lower.tail = TRUE, log.p = FALSE) +rhurdle_poisson(n, lambda, hu) + dhurdle_negbinomial(x, mu, shape, hu, log = FALSE) phurdle_negbinomial(q, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) qhurdle_negbinomial(p, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) +rhurdle_negbinomial(n, mu, shape, hu) + dhurdle_gamma(x, shape, scale, hu, log = FALSE) phurdle_gamma(q, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) qhurdle_gamma(p, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) +rhurdle_gamma(n, shape, scale, hu) + dhurdle_lognormal(x, mu, sigma, hu, log = FALSE) phurdle_lognormal(q, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) qhurdle_lognormal(p, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) + +rhurdle_lognormal(n, mu, sigma, hu) } \arguments{ \item{x}{Vector of quantiles.} @@ -56,6 +68,8 @@ Else, return P(X > x) .} \item{p}{Vector of probabilities.} +\item{n}{Number of draws to sample from the distribution.} + \item{mu, lambda}{location parameter} \item{shape}{shape parameter} @@ -63,7 +77,8 @@ Else, return P(X > x) .} \item{sigma, scale}{scale parameter} } \description{ -Density and distribution functions for hurdle distributions. +Density, distribution function, quantile function and random generation +for hurdle distributions. } \details{ The density of a hurdle distribution can be specified as follows. diff --git a/man/brms-package.Rd b/man/brms-package.Rd index d63633ebc..538d8e07c 100644 --- a/man/brms-package.Rd +++ b/man/brms-package.Rd @@ -85,6 +85,11 @@ version 2.21.2. \url{https://mc-stan.org/} \author{ \strong{Maintainer}: Paul-Christian Bürkner \email{paul.buerkner@gmail.com} +Authors: +\itemize{ + \item Paul-Christian Bürkner \email{paul.buerkner@gmail.com} +} + Other contributors: \itemize{ \item Jonah Gabry [contributor] diff --git a/man/posterior_predict.brmsfit.Rd b/man/posterior_predict.brmsfit.Rd index 09f67b692..01fdd70a4 100644 --- a/man/posterior_predict.brmsfit.Rd +++ b/man/posterior_predict.brmsfit.Rd @@ -75,7 +75,9 @@ for truncated discrete models only \item{output}{The type of output to return. Can be \code{"random"}, \code{"probability"}, \code{"pit"}, \code{"density"}, or \code{"quantile"}. Defaults to \code{"random"}. In case of continuous -distributions, \code{"probability"} is equivalent to \code{"pit"}.} +distributions, \code{"probability"} is equivalent to \code{"pit"}. +Not all families support outputs other than \code{"random"} yet; +requesting an unsupported combination raises an error.} \item{q}{Custom quantile for computing probability, PIT, or density values. It defaults to NULL in which case \code{prep$data$Y[i]} is used.} diff --git a/man/predict.brmsfit.Rd b/man/predict.brmsfit.Rd index 8e9c7fdd2..2c4fe9fa0 100644 --- a/man/predict.brmsfit.Rd +++ b/man/predict.brmsfit.Rd @@ -84,7 +84,9 @@ function. Only used if \code{summary} is \code{TRUE}.} \item{output}{The type of output to return. Can be \code{"random"}, \code{"probability"}, \code{"pit"}, \code{"density"}, or \code{"quantile"}. Defaults to \code{"random"}. In case of continuous -distributions, \code{"probability"} is equivalent to \code{"pit"}.} +distributions, \code{"probability"} is equivalent to \code{"pit"}. +Not all families support outputs other than \code{"random"} yet; +requesting an unsupported combination raises an error.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} diff --git a/man/psis.brmsfit.Rd b/man/psis.brmsfit.Rd index 2af401ca9..b9844797d 100644 --- a/man/psis.brmsfit.Rd +++ b/man/psis.brmsfit.Rd @@ -49,7 +49,7 @@ page for details. } } -Objects of class \code{"psis"} also have the following \link[=attributes]{attributes}: +Objects of class \code{"psis"} also have the following \link{attributes}: \describe{ \item{\code{norm_const_log}}{ Vector of precomputed values of \code{colLogSumExps(log_weights)} that are diff --git a/notes/pr-summary.md b/notes/pr-summary.md new file mode 100644 index 000000000..294453fb6 --- /dev/null +++ b/notes/pr-summary.md @@ -0,0 +1,53 @@ +# PR summary: extended `posterior_predict()` outputs + +Branch: `posterior_pit` +Related PR: [paul-buerkner/brms#1857](https://github.com/paul-buerkner/brms/pull/1857) + +## Detailed overviews (upstream PR comments) + +Family-by-family support tables live in two comments on #1857: + +- [`posterior_predict()` `output` support](https://github.com/paul-buerkner/brms/pull/1857#issuecomment-4325781243) — which methods support `random` / `probability` / `density` / `pit` / `quantile` +- [Distribution helpers in `R/distributions.R`](https://github.com/paul-buerkner/brms/pull/1857#issuecomment-4325820624) — which families have `d` / `p` / `q` / `r` (including newly added helpers) + +## What + +Extends `posterior_predict()` beyond random draws so it can return CDF/PIT values, densities/PMFs, and quantiles for many response families, with matching distribution helpers (`p`/`d`/`q`/`r`) where needed. + +## Changes + +### API (`posterior_predict()` / `predict()`) + +New arguments (default preserves old behavior: `output = "random"`): + +| Argument | Role | +|----------|------| +| `output` | `"random"`, `"probability"`, `"pit"`, `"density"`, or `"quantile"` | +| `q` | query point for probability / PIT / density (defaults to observed `Y`) | +| `p` | probability for quantiles | +| `lower.tail`, `log.p`, `log` | CDF / quantile / density options | + +Shared backends: `predict_continuous_helper()`, `predict_discrete_helper()`, plus validation that rejects unsupported `output` × family combinations. + +### Distributions (`R/distributions.R`) + +New or extended helpers used by the predictive methods, including quantile functions for inverse Gaussian, ex-Gaussian, von Mises, COM-Poisson, beta-binomial, zero-inflated / hurdle families, and `d`/`p`/`q` for zero-one-inflated beta; plus ordinal / categorical / hurdle-cumulative support. + +### Tests and docs + +- Spec-driven tests (`helper-distributions.R`, `helper-posterior-predict.R`) covering supported modes, truncation where applicable, and relations between `d`/`p`/`q`/`r` +- Vignettes: `brms_posterior_predict.Rmd`, `brms_distribution_output_cheatsheet.Rmd` + +## Caveats + +1. **Not all families support all modes.** Multivariate / time / spatial / residual-correlation Gaussians and Students, Wiener, multinomial / Dirichlet(-multinomial) / logistic-normal, and `mixture` accept only `output = "random"`. `cox` still has no predictive draws. Custom families default to `random` unless they implement other modes. + +2. **Discrete PIT is randomized.** Continuous `probability` and `pit` coincide; discrete `pit` uses randomized PIT to avoid point-mass spikes. + +3. **Discrete truncation still uses rejection sampling** (`ntrys`); pathological bounds can be slow or approximate (existing brms behavior). Hurdle families now respect truncation for `output = "random"` (continuous via inverse CDF; discrete via rejection). Some zero-inflated families still overlay exact zeros after truncated base sampling, so draws of 0 can fall outside `lb > 0` bounds (pre-existing pattern). + +4. **Some quantiles are numerical.** Families without closed-form inverses (e.g. inverse Gaussian, ex-Gaussian, von Mises, COM-Poisson, several zero-inflated / hurdle CDFs) invert the CDF numerically (`tol` where exposed). + +5. **Optional Suggests.** Full coverage of `skew_normal` / `xbeta` in the cheatsheet needs `mnormt` / `betareg`. + + diff --git a/tests/testthat/helper-distributions.R b/tests/testthat/helper-distributions.R index 7fcee7a11..bcefa82e9 100644 --- a/tests/testthat/helper-distributions.R +++ b/tests/testthat/helper-distributions.R @@ -15,7 +15,8 @@ # 5. Flags (logical list), common ones: # truncation - exercise truncated CDF/PDF/quantile # numeric_q - quantile solved numerically -# no_random_truncation- random sampling ignores truncation (warns) +# no_random_truncation- truncated random draws may leave [lb, ub] +# (e.g. ZI overlay of zeros after truncated sampling) # zi / hurdle - mixture formulas vs a baseline d/p # skip_integrate - skip integrate-to-one (e.g. circular, heavy tails) # skip_moments - skip moment checks @@ -568,7 +569,7 @@ dist_registry_populate <- function(reset = TRUE) { d = brms:::dhurdle_poisson, p = brms:::phurdle_poisson, q = brms:::qhurdle_poisson, - r = NULL, + r = brms:::rhurdle_poisson, params = list(lambda = 2, hu = 0.2), support = c(0, Inf), pp_fun = brms:::posterior_predict_hurdle_poisson, @@ -588,7 +589,6 @@ dist_registry_populate <- function(reset = TRUE) { flags = list( truncation = TRUE, hurdle = TRUE, - no_random_truncation = TRUE, skip_moments = TRUE ) )) @@ -620,6 +620,7 @@ dist_registry_populate <- function(reset = TRUE) { flags = list( truncation = TRUE, zi = TRUE, + no_random_truncation = TRUE, skip_moments = TRUE ) )) @@ -1093,7 +1094,7 @@ dist_registry_populate <- function(reset = TRUE) { d = dhurdle_negbinomial, p = phurdle_negbinomial, q = qhurdle_negbinomial, - r = NULL, + r = rhurdle_negbinomial, params = list(mu = 4, shape = 2.5, hu = 0.2), support = c(0, Inf), pp_fun = brms:::posterior_predict_hurdle_negbinomial, @@ -1113,7 +1114,6 @@ dist_registry_populate <- function(reset = TRUE) { flags = list( truncation = TRUE, hurdle = TRUE, - no_random_truncation = TRUE, skip_moments = TRUE ) )) @@ -1125,7 +1125,7 @@ dist_registry_populate <- function(reset = TRUE) { d = dhurdle_gamma, p = phurdle_gamma, q = qhurdle_gamma, - r = NULL, + r = rhurdle_gamma, params = list(shape = 2, scale = 1, hu = 0.2), support = c(0, Inf), pp_fun = brms:::posterior_predict_hurdle_gamma, @@ -1144,9 +1144,8 @@ dist_registry_populate <- function(reset = TRUE) { mix = "hu" ), flags = list( - truncation = FALSE, + truncation = TRUE, hurdle = TRUE, - no_random_truncation = TRUE, skip_integrate = TRUE, skip_moments = TRUE, skip_pdf_fd = TRUE, @@ -1161,7 +1160,7 @@ dist_registry_populate <- function(reset = TRUE) { d = dhurdle_lognormal, p = phurdle_lognormal, q = qhurdle_lognormal, - r = NULL, + r = rhurdle_lognormal, params = list(mu = 0, sigma = 1, hu = 0.2), support = c(0, Inf), pp_fun = brms:::posterior_predict_hurdle_lognormal, @@ -1180,9 +1179,8 @@ dist_registry_populate <- function(reset = TRUE) { mix = "hu" ), flags = list( - truncation = FALSE, + truncation = TRUE, hurdle = TRUE, - no_random_truncation = TRUE, skip_integrate = TRUE, skip_moments = TRUE, skip_pdf_fd = TRUE, @@ -1217,6 +1215,7 @@ dist_registry_populate <- function(reset = TRUE) { flags = list( truncation = TRUE, zi = TRUE, + no_random_truncation = TRUE, skip_moments = TRUE ) )) @@ -1248,6 +1247,7 @@ dist_registry_populate <- function(reset = TRUE) { flags = list( truncation = TRUE, zi = TRUE, + no_random_truncation = TRUE, skip_moments = TRUE ) )) @@ -1282,6 +1282,7 @@ dist_registry_populate <- function(reset = TRUE) { flags = list( truncation = TRUE, zi = TRUE, + no_random_truncation = TRUE, skip_moments = TRUE ) )) diff --git a/tests/testthat/helper-posterior-predict.R b/tests/testthat/helper-posterior-predict.R index ddd08a7ba..fc317d336 100644 --- a/tests/testthat/helper-posterior-predict.R +++ b/tests/testthat/helper-posterior-predict.R @@ -291,6 +291,16 @@ expect_pp_truncation <- function(entry, i = 1L, lb = NULL, ub = NULL, tolerance = 1e-5, info = paste(entry$name, "PP trunc quantile")) } + + if (has_output(entry, "random") && + !isTRUE(entry$flags$no_random_truncation)) { + set.seed(seed) + got_r <- entry$pp_fun(i, prep = prep, output = "random", ntrys = 20) + testthat::expect_true( + all(got_r >= lb - 1e-8 & got_r <= ub + 1e-8, na.rm = TRUE), + info = paste(entry$name, "PP trunc random in [lb, ub]") + ) + } invisible(TRUE) } diff --git a/tests/testthat/tests.distributions.R b/tests/testthat/tests.distributions.R index 652b44bcc..4ff592dd6 100644 --- a/tests/testthat/tests.distributions.R +++ b/tests/testthat/tests.distributions.R @@ -232,21 +232,35 @@ test_that("hurdle distribution functions run without errors", { p <- rbeta(n, shape1 = 2, shape2 = 2) res <- qhurdle_poisson(p, lambda = 1, hu = 0.1) expect_true(length(res) == n) + res <- rhurdle_poisson(n, lambda = 1, hu = 0.1) + expect_true(length(res) == n) res <- dhurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) expect_true(length(res) == n) res <- phurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) expect_true(length(res) == n) + res <- qhurdle_negbinomial(p, mu = 2, shape = 5, hu = 0.1) + expect_true(length(res) == n) + res <- rhurdle_negbinomial(n, mu = 2, shape = 5, hu = 0.1) + expect_true(length(res) == n) res <- dhurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) expect_true(length(res) == n) res <- phurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) expect_true(length(res) == n) + res <- qhurdle_gamma(p, shape = 1, scale = 3, hu = 0.1) + expect_true(length(res) == n) + res <- rhurdle_gamma(n, shape = 1, scale = 3, hu = 0.1) + expect_true(length(res) == n) res <- dhurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) expect_true(length(res) == n) res <- phurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) expect_true(length(res) == n) + res <- qhurdle_lognormal(p, mu = 2, sigma = 5, hu = 0.1) + expect_true(length(res) == n) + res <- rhurdle_lognormal(n, mu = 2, sigma = 5, hu = 0.1) + expect_true(length(res) == n) }) test_that("wiener distribution functions run without errors", { diff --git a/vignettes/brms_distribution_output_cheatsheet.Rmd b/vignettes/brms_distribution_output_cheatsheet.Rmd index 45f4ea13e..7049cd288 100644 --- a/vignettes/brms_distribution_output_cheatsheet.Rmd +++ b/vignettes/brms_distribution_output_cheatsheet.Rmd @@ -292,7 +292,7 @@ specs <- list( d = function(x) dhurdle_poisson(x, lambda = 5, hu = 0.25), cdf = function(q) phurdle_poisson(q, lambda = 5, hu = 0.25), qf = function(p) qhurdle_poisson(p, lambda = 5, hu = 0.25), - r = function(n) r_from_q(qhurdle_poisson, n, lambda = 5, hu = 0.25) + r = function(n) rhurdle_poisson(n, lambda = 5, hu = 0.25) ), list( family = "hurdle_negbinomial", type = "discrete", x = 0:24, @@ -300,9 +300,7 @@ specs <- list( d = function(x) dhurdle_negbinomial(x, mu = 5, shape = 2, hu = 0.25), cdf = function(q) phurdle_negbinomial(q, mu = 5, shape = 2, hu = 0.25), qf = function(p) qhurdle_negbinomial(p, mu = 5, shape = 2, hu = 0.25), - r = function(n) { - r_from_q(qhurdle_negbinomial, n, mu = 5, shape = 2, hu = 0.25) - } + r = function(n) rhurdle_negbinomial(n, mu = 5, shape = 2, hu = 0.25) ), list( family = "hurdle_gamma", type = "mixture", x = seq(0, 10, length.out = 200), @@ -310,7 +308,7 @@ specs <- list( d = function(x) dhurdle_gamma(x, shape = 2, scale = 1, hu = 0.25), cdf = function(q) phurdle_gamma(q, shape = 2, scale = 1, hu = 0.25), qf = function(p) qhurdle_gamma(p, shape = 2, scale = 1, hu = 0.25), - r = function(n) r_from_q(qhurdle_gamma, n, shape = 2, scale = 1, hu = 0.25) + r = function(n) rhurdle_gamma(n, shape = 2, scale = 1, hu = 0.25) ), list( family = "hurdle_lognormal", type = "mixture", @@ -319,7 +317,7 @@ specs <- list( d = function(x) dhurdle_lognormal(x, mu = 0, sigma = 1, hu = 0.25), cdf = function(q) phurdle_lognormal(q, mu = 0, sigma = 1, hu = 0.25), qf = function(p) qhurdle_lognormal(p, mu = 0, sigma = 1, hu = 0.25), - r = function(n) r_from_q(qhurdle_lognormal, n, mu = 0, sigma = 1, hu = 0.25) + r = function(n) rhurdle_lognormal(n, mu = 0, sigma = 1, hu = 0.25) ), list( family = "hurdle_cumulative", type = "discrete", x = 0:4, @@ -701,9 +699,9 @@ output modes (or cannot draw from the predictive at all): | Survival (no predictive draws) | `cox` | none (`posterior_predict()` errors) | | User-defined | `custom` | `random` by default; other modes only if the custom family implements them | -Truncation note: even among fully supported families, truncated **random** -sampling is not implemented for several hurdle families (they warn and ignore -bounds for `output = "random"`). +Truncation is handled via the shared continuous (inverse-CDF) and discrete +(rejection sampling) helpers for all fully supported families, including the +hurdle families. ## Mathematical details From 529ea2a43e599e137802a0b8ea50b0cfa41ab903 Mon Sep 17 00:00:00 2001 From: Florence Bockting Date: Mon, 20 Jul 2026 16:06:23 +0300 Subject: [PATCH 63/63] fix: random sampling of rordinal --- R/distributions.R | 11 +++-- R/posterior_predict.R | 92 ++++++++++++++++++++--------------------- R/prepare_predictions.R | 2 +- 3 files changed, 54 insertions(+), 51 deletions(-) diff --git a/R/distributions.R b/R/distributions.R index ad7f1255c..346e38637 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -2566,7 +2566,7 @@ qhurdle_cumulative <- function(p, eta, thres, hu, disc = 1, link = "logit", # random generation for the hurdle-cumulative distribution rhurdle_cumulative <- function(n, eta, thres, hu, disc = 1, link = "logit") { - n <- check_n_rdist(n, eta, hu, disc) + n <- check_n_rdist(n, eta, thres, hu, disc) qhurdle_cumulative( runif(n), eta = eta, thres = thres, hu = hu, disc = disc, link = link ) @@ -3308,7 +3308,7 @@ qordinal <- function(p, eta, thres, disc = 1, family = NULL, link = "logit", # @param link a character string naming the link # @return a vector of category indices rordinal <- function(n, eta, thres, disc = 1, family = NULL, link = "logit") { - n <- check_n_rdist(n, eta, disc) + n <- check_n_rdist(n, eta, thres, disc) qordinal( runif(n), eta = eta, thres = thres, disc = disc, family = family, link = link @@ -3349,11 +3349,14 @@ validate_p_dist <- function(p, lower.tail = TRUE, log.p = FALSE) { # check if 'n' in r functions is valid # @param n number of desired random draws -# @param .. parameter vectors +# @param .. parameter vectors or matrices (draws in rows) # @return validated 'n' check_n_rdist <- function(n, ...) { n <- as.integer(as_one_numeric(n)) - max_len <- max(lengths(list(...))) + # matrices use NROW (number of draws), not length (nrow * ncol) + max_len <- max(vapply(list(...), function(x) { + if (!is.null(dim(x))) NROW(x) else length(x) + }, integer(1))) if (max_len > 1L) { if (!n %in% c(1, max_len)) { stop2("'n' must match the maximum length of the parameter vectors.") diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 4f004b746..9cbe744b4 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -341,7 +341,7 @@ posterior_predict_gaussian <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "norm", mean = mu, sd = sigma, ... + distribution = "norm", mean = mu, sd = sigma, ... ) } @@ -354,7 +354,7 @@ posterior_predict_student <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "student_t", df = nu, mu = mu, sigma = sigma, ... + distribution = "student_t", df = nu, mu = mu, sigma = sigma, ... ) } @@ -365,7 +365,7 @@ posterior_predict_lognormal <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "lnorm", meanlog = mu, sdlog = sigma, ... + distribution = "lnorm", meanlog = mu, sdlog = sigma, ... ) } @@ -377,7 +377,7 @@ posterior_predict_shifted_lognormal <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "shifted_lnorm", meanlog = mu, sdlog = sigma, shift = ndt, ... + distribution = "shifted_lnorm", meanlog = mu, sdlog = sigma, shift = ndt, ... ) } @@ -390,7 +390,7 @@ posterior_predict_skew_normal <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "skew_normal", mu = mu, sigma = sigma, alpha = alpha, ... + distribution = "skew_normal", mu = mu, sigma = sigma, alpha = alpha, ... ) } @@ -528,7 +528,7 @@ posterior_predict_binomial <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "binom", prob = mu, size = size, ... + distribution = "binom", prob = mu, size = size, ... ) } @@ -540,7 +540,7 @@ posterior_predict_beta_binomial <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "beta_binomial", size = size, mu = mu, phi = phi, ... + distribution = "beta_binomial", size = size, mu = mu, phi = phi, ... ) } @@ -550,7 +550,7 @@ posterior_predict_bernoulli <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "binom", prob = mu, size = 1, ... + distribution = "binom", prob = mu, size = 1, ... ) } @@ -561,7 +561,7 @@ posterior_predict_poisson <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "pois", lambda = mu, ... + distribution = "pois", lambda = mu, ... ) } @@ -574,7 +574,7 @@ posterior_predict_negbinomial <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "nbinom", mu = mu, size = shape, ... + distribution = "nbinom", mu = mu, size = shape, ... ) } @@ -587,7 +587,7 @@ posterior_predict_negbinomial2 <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "nbinom", mu = mu, size = shape, ... + distribution = "nbinom", mu = mu, size = shape, ... ) } @@ -600,7 +600,7 @@ posterior_predict_geometric <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "nbinom", mu = mu, size = shape, ... + distribution = "nbinom", mu = mu, size = shape, ... ) } @@ -611,7 +611,7 @@ posterior_predict_discrete_weibull <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "discrete_weibull", mu = mu, shape = shape, ... + distribution = "discrete_weibull", mu = mu, shape = shape, ... ) } @@ -622,7 +622,7 @@ posterior_predict_com_poisson <- function(i, prep, output = "random", predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "com_poisson", mu = mu, shape = shape, ... + distribution = "com_poisson", mu = mu, shape = shape, ... ) } @@ -633,7 +633,7 @@ posterior_predict_exponential <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "exp", rate = rate, ... + distribution = "exp", rate = rate, ... ) } @@ -644,7 +644,7 @@ posterior_predict_gamma <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "gamma", shape = shape, scale = scale, ... + distribution = "gamma", shape = shape, scale = scale, ... ) } @@ -655,7 +655,7 @@ posterior_predict_weibull <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "weibull", shape = shape, scale = scale, ... + distribution = "weibull", shape = shape, scale = scale, ... ) } @@ -667,7 +667,7 @@ posterior_predict_frechet <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "frechet", scale = scale, shape = nu, ... + distribution = "frechet", scale = scale, shape = nu, ... ) } @@ -679,7 +679,7 @@ posterior_predict_gen_extreme_value <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "gen_extreme_value", sigma = sigma, xi = xi, mu = mu, ... + distribution = "gen_extreme_value", sigma = sigma, xi = xi, mu = mu, ... ) } @@ -690,7 +690,7 @@ posterior_predict_inverse.gaussian <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "inv_gaussian", mu = mu, shape = shape, ... + distribution = "inv_gaussian", mu = mu, shape = shape, ... ) } @@ -702,7 +702,7 @@ posterior_predict_exgaussian <- function(i, prep, output = "random", ntrys = 5, predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "exgaussian", mu = mu, sigma = sigma, beta = beta, ... + distribution = "exgaussian", mu = mu, sigma = sigma, beta = beta, ... ) } @@ -710,7 +710,7 @@ posterior_predict_wiener <- function(i, prep, output = "random", negative_rt = FALSE, ntrys = 5, ...) { validate_pp_output_support("wiener", output) out <- rcontinuous( - n = 1, dist = "wiener", + n = 1, distribution = "wiener", delta = get_dpar(prep, "mu", i = i), alpha = get_dpar(prep, "bs", i = i), tau = get_dpar(prep, "ndt", i = i), @@ -732,7 +732,7 @@ posterior_predict_beta <- function(i, prep, output = "random", ntrys = 5, ...) { predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "beta", shape1 = mu * phi, shape2 = (1 - mu) * phi, ... + distribution = "beta", shape1 = mu * phi, shape2 = (1 - mu) * phi, ... ) } @@ -743,7 +743,7 @@ posterior_predict_xbeta <- function(i, prep, output = "random", ntrys = 5, ...) predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "xbeta", mu = mu, phi = phi, nu = kappa, ... + distribution = "xbeta", mu = mu, phi = phi, nu = kappa, ... ) } @@ -754,7 +754,7 @@ posterior_predict_von_mises <- function(i, prep, output = "random", ntrys = 5, predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "von_mises", mu = mu, kappa = kappa, ... + distribution = "von_mises", mu = mu, kappa = kappa, ... ) } @@ -766,7 +766,7 @@ posterior_predict_asym_laplace <- function(i, prep, output = "random", predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "asym_laplace", mu = mu, sigma = sigma, quantile = quantile, ... + distribution = "asym_laplace", mu = mu, sigma = sigma, quantile = quantile, ... ) } @@ -781,14 +781,14 @@ posterior_predict_zero_inflated_asym_laplace <- function(i, prep, if (output == "random") { out <- predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "asym_laplace", mu = mu, sigma = sigma, quantile = quantile, ... + distribution = "asym_laplace", mu = mu, sigma = sigma, quantile = quantile, ... ) tmp <- runif(prep$ndraws, 0, 1) out <- ifelse(tmp < zi, 0, out) } else { out <- predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "zero_inflated_asym_laplace", + distribution = "zero_inflated_asym_laplace", mu = mu, sigma = sigma, quantile = quantile, zi = zi, ... ) } @@ -807,7 +807,7 @@ posterior_predict_hurdle_poisson <- function(i, prep, output = "random", lambda <- multiply_dpar_rate_denom(lambda, prep, i = i) predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_poisson", lambda = lambda, hu = hu, ... + distribution = "hurdle_poisson", lambda = lambda, hu = hu, ... ) } @@ -819,7 +819,7 @@ posterior_predict_hurdle_negbinomial <- function(i, prep, output = "random", shape <- get_dpar(prep, "shape", i = i) predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_negbinomial", mu = mu, shape = shape, hu = hu, ... + distribution = "hurdle_negbinomial", mu = mu, shape = shape, hu = hu, ... ) } @@ -830,7 +830,7 @@ posterior_predict_hurdle_gamma <- function(i, prep, output = "random", scale <- get_dpar(prep, "mu", i = i) / shape predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_gamma", shape = shape, scale = scale, hu = hu, ... + distribution = "hurdle_gamma", shape = shape, scale = scale, hu = hu, ... ) } @@ -841,7 +841,7 @@ posterior_predict_hurdle_lognormal <- function(i, prep, output = "random", sigma <- get_dpar(prep, "sigma", i = i) predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "hurdle_lognormal", mu = mu, sigma = sigma, hu = hu, ... + distribution = "hurdle_lognormal", mu = mu, sigma = sigma, hu = hu, ... ) } @@ -849,7 +849,7 @@ posterior_predict_hurdle_cumulative <- function(i, prep, output = "random", ...) { predict_discrete_helper( i = i, prep = prep, output = output, - dist = "hurdle_cumulative", + distribution = "hurdle_cumulative", eta = get_dpar(prep, "mu", i = i), disc = get_dpar(prep, "disc", i = i), hu = get_dpar(prep, "hu", i = i), @@ -870,14 +870,14 @@ posterior_predict_zero_inflated_beta <- function(i, prep, output = "random", if (output == "random") { out <- predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "beta", shape1 = shape1, shape2 = shape2, ... + distribution = "beta", shape1 = shape1, shape2 = shape2, ... ) tmp <- runif(prep$ndraws, 0, 1) out <- ifelse(tmp < zi, 0, out) } else { out <- predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "zero_inflated_beta", shape1 = shape1, shape2 = shape2, zi = zi, ... + distribution = "zero_inflated_beta", shape1 = shape1, shape2 = shape2, zi = zi, ... ) } out @@ -903,7 +903,7 @@ posterior_predict_zero_one_inflated_beta <- function(i, prep, output = "random", } else { out <- predict_continuous_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "zero_one_inflated_beta", + distribution = "zero_one_inflated_beta", shape1 = shape1, shape2 = shape2, zoi = zoi, coi = coi, ... ) } @@ -920,14 +920,14 @@ posterior_predict_zero_inflated_poisson <- function(i, prep, output = "random", if (output == "random") { out <- predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "pois", lambda = lambda, ... + distribution = "pois", lambda = lambda, ... ) tmp <- runif(prep$ndraws, 0, 1) out <- ifelse(tmp < zi, 0L, out) } else { out <- predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "zero_inflated_poisson", lambda = lambda, zi = zi, ... + distribution = "zero_inflated_poisson", lambda = lambda, zi = zi, ... ) } out @@ -941,12 +941,12 @@ posterior_predict_zero_inflated_negbinomial <- function(i, prep, if (output == "random") { out <- predict_discrete_helper(i = i, prep = prep, output = output, - dist = "nbinom", mu = mu, size = shape, ...) + distribution = "nbinom", mu = mu, size = shape, ...) tmp <- runif(prep$ndraws, 0, 1) out <- ifelse(tmp < zi, 0L, out) } else { out <- predict_discrete_helper(i = i, prep = prep, output = output, - dist = "zero_inflated_negbinomial", mu = mu, shape = shape, zi = zi, ...) + distribution = "zero_inflated_negbinomial", mu = mu, shape = shape, zi = zi, ...) } out } @@ -960,14 +960,14 @@ posterior_predict_zero_inflated_binomial <- function(i, prep, output = "random", if (output == "random") { out <- predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "binom", size = trials, prob = prob, ... + distribution = "binom", size = trials, prob = prob, ... ) tmp <- runif(prep$ndraws, 0, 1) out <- ifelse(tmp < zi, 0L, out) } else { out <- predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "zero_inflated_binomial", size = trials, prob = prob, zi = zi, ... + distribution = "zero_inflated_binomial", size = trials, prob = prob, zi = zi, ... ) } out @@ -984,14 +984,14 @@ posterior_predict_zero_inflated_beta_binomial <- function(i, prep, if (output == "random") { out <- predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "beta_binomial", size = trials, mu = mu, phi = phi, ... + distribution = "beta_binomial", size = trials, mu = mu, phi = phi, ... ) tmp <- runif(prep$ndraws, 0, 1) out <- ifelse(tmp < zi, 0L, out) } else { out <- predict_discrete_helper( i = i, prep = prep, output = output, ntrys = ntrys, - dist = "zero_inflated_beta_binomial", + distribution = "zero_inflated_beta_binomial", size = trials, mu = mu, phi = phi, zi = zi, ... ) } @@ -1003,7 +1003,7 @@ posterior_predict_categorical <- function(i, prep, output = "random", ...) { eta <- insert_refcat(eta, refcat = prep$refcat) predict_discrete_helper( i = i, prep = prep, output = output, - dist = "categorical", + distribution = "categorical", eta = eta, ... ) @@ -1080,7 +1080,7 @@ posterior_predict_ordinal <- function(i, prep, output = "random", ...) { predict_discrete_helper( i = i, prep = prep, output = output, - dist = "ordinal", + distribution = "ordinal", eta = eta, disc = disc, thres = thres, diff --git a/R/prepare_predictions.R b/R/prepare_predictions.R index 1b0d9b415..0c4b8dd2b 100644 --- a/R/prepare_predictions.R +++ b/R/prepare_predictions.R @@ -376,7 +376,7 @@ prepare_predictions_sp <- function(bframe, draws, sdata, new = FALSE, ...) { warn_me <- warn_me || !new sdy <- data2draws(sdy, dim) out$Yl[[i]] <- rcontinuous( - n = prod(dim), dist = "norm", + n = prod(dim), distribution = "norm", mean = Y, sd = sdy, lb = sdata[[paste0("lbmi_", vmi)]], ub = sdata[[paste0("ubmi_", vmi)]]