From 522562f0389fefbc5c3872b9fab21c5e743a0108 Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 20:38:49 -0700 Subject: [PATCH 1/8] Fixed R devel apply --- NAMESPACE | 1 + R/rvar-cast.R | 1173 ++++++++++++++++--------------- tests/testthat/test-rvar-cast.R | 11 + 3 files changed, 602 insertions(+), 583 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 216cf1ce..e40ee84a 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,6 +39,7 @@ S3method(anyDuplicated,rvar) S3method(anyDuplicated,rvar_factor) S3method(anyNA,rvar) S3method(aperm,rvar) +S3method(as.array,rvar) S3method(as.data.frame,rvar) S3method(as.list,rvar) S3method(as.vector,rvar) diff --git a/R/rvar-cast.R b/R/rvar-cast.R index bdcfb209..d746f36b 100755 --- a/R/rvar-cast.R +++ b/R/rvar-cast.R @@ -1,583 +1,590 @@ -#' Coerce to a random variable -#' -#' Convert `x` to an [`rvar`] object. -#' -#' @param x (multiple options) An object that can be converted to an [`rvar`], -#' such as a vector, array, or an [`rvar`] itself. -#' @template args-rvar-dim -#' @template args-rvar-dimnames -#' @param nchains (positive integer) The number of chains. The default is `1`. -#' -#' @details For objects that are already [`rvar`]s, returns them (with modified dimensions -#' if `dim` is not `NULL`). -#' -#' For numeric or logical vectors or arrays, returns an [`rvar`] with a single draw and -#' the same dimensions as `x`. This is in contrast to the [rvar()] constructor, which -#' treats the first dimension of `x` as the draws dimension. As a result, `as_rvar()` -#' is useful for creating constants. -#' -#' While `as_rvar()` attempts to pick the most suitable subtype of [`rvar`] based on the -#' type of `x` (possibly returning an [`rvar_factor`] or [`rvar_ordered`]), -#' `as_rvar_numeric()`, `as_rvar_integer()`, and `as_rvar_logical()` always coerce -#' the draws of the output [`rvar`] to be [`numeric`], [`integer`], or [`logical`] -#' (respectively), and always return a base [`rvar`], never a subtype. -#' -#' @seealso [rvar()] to construct [`rvar`]s directly. See [rdo()], [rfun()], and -#' [rvar_rng()] for higher-level interfaces for creating `rvar`s. -#' -#' @return An object of class `"rvar"` (or one of its subtypes) representing a random variable. -#' -#' @examples -#' -#' # You can use as_rvar() to create "constant" rvars (having only one draw): -#' x <- as_rvar(1) -#' x -#' -#' # Such constants can be of arbitrary shape: -#' as_rvar(1:4) -#' as_rvar(matrix(1:10, nrow = 5)) -#' as_rvar(array(1:12, dim = c(2, 3, 2))) -#' -#' # as_rvar_numeric() coerces subtypes of rvar to the base rvar type -#' y <- as_rvar_factor(c("a", "b", "c")) -#' y -#' as_rvar_numeric(y) -#' -#' @export -as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - .as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) -} -.as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL, ptype = new_rvar()) { - out <- x - - if (is.null(out)) { - out <- rvar() - } else { - out <- vec_cast(out, ptype) - } - - if (!is.null(dim)) { - dim(out) <- dim - } else if (is.null(dimnames) && is.vector(x)) { - # for non-vector-like input (matrices, arrays, etc), vec_cast should - # have already copied over the dimnames correctly. For vector-like input, - # it doesn't; so as long as the `dim` argument isn't set we can copy - # the name over - names(out) <- names(x) - } - if (!is.null(dimnames)) { - dimnames(out) <- dimnames - } - - if (!is.null(nchains)) { - .ndraws <- ndraws(out) - nchains <- as_one_integer(nchains) - check_nchains_compat_with_ndraws(nchains, .ndraws) - nchains_rvar(out) <- nchains - } - - out -} - -#' @rdname as_rvar -#' @export -as_rvar_numeric <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) - .draws <- draws_of(out) - draws_of(out) <- copy_dims(.draws, as.numeric(.draws)) - out -} - -#' @rdname as_rvar -#' @export -as_rvar_integer <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) - .draws <- draws_of(out) - draws_of(out) <- copy_dims(.draws, as.integer(.draws)) - out -} - -#' @rdname as_rvar -#' @export -as_rvar_logical <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) - .draws <- draws_of(out) - draws_of(out) <- copy_dims(.draws, as.logical(.draws)) - out -} - - -# type predicates -------------------------------------------------- - -#' Is `x` a random variable? -#' -#' Test if `x` is an [`rvar`]. -#' -#' @param x (any object) An object to test. -#' -#' @seealso [as_rvar()] to convert objects to `rvar`s. -#' -#' @return `TRUE` if `x` is an [`rvar`], `FALSE` otherwise. -#' -#' @export -is_rvar <- function(x) { - inherits(x, "rvar") -} - -#' @export -is.matrix.rvar <- function(x) { - length(dim(draws_of(x))) == 3 -} - -#' @export -is.array.rvar <- function(x) { - length(dim(draws_of(x))) > 0 -} - - -# type conversion --------------------------------------------------------- - -#' @export -as.vector.rvar <- function(x, mode = "any") { - dim(x) <- NULL - names(x) <- NULL - x -} - -#' @export -as.list.rvar <- function(x, ...) { - x_dim <- dim(x) - - if (length(x_dim) >= 2) { - is <- seq_len(x_dim[[1]]) - names(is) <- dimnames(x)[[1]] - out <- lapply(is, function(i) { - out_i <- x[i,] - .dim <- dim(out_i) - .dimnames <- dimnames(out_i) - dim(out_i) <- .dim[-1] - dimnames(out_i) <- .dimnames[-1] - out_i - }) - } else { - is <- seq_along(x) - names(is) <- dimnames(x)[[1]] - out <- lapply(is, function(i) x[[i]]) - } - out -} - -#' @importFrom rlang as_label -#' @export -as.data.frame.rvar <- function(x, ..., optional = FALSE) { - out <- as.data.frame.array(x, ..., optional = optional) - if (length(dim(x)) <= 1 && !optional) { - names(out) <- as_label(substitute(x)) - } - out -} - -#' @importFrom tibble as_tibble -#' @export -as_tibble.rvar <- function(x, ...) { - #default name for vectors is `value` with as_tibble - value <- x - as_tibble(as.data.frame(value, optional = FALSE), ...) -} - - -# vctrs proxy / restore -------------------------------------------------------- - -invalidate_rvar_cache = function(x) { - attr(x, "cache") <- new.env(parent = emptyenv()) - x -} - -#' @importFrom vctrs vec_proxy -#' @export -vec_proxy.rvar = function(x, ...) { - # Using caching to help with algorithms that call vec_proxy - # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 - - out <- attr(x, "cache")$vec_proxy - if (is.null(out)) { - # proxy is not in the cache, calculate it and store it in the cache - out <- make_rvar_proxy(x) - attr(x, "cache")$vec_proxy <- out - } - - out -} - -#' Make a cacheable proxy for vec_proxy.rvar -#' @noRd -make_rvar_proxy = function(x) { - nchains <- nchains(x) - draws <- draws_of(x) - is <- seq_len(NROW(x)) - names(is) <- rownames(x) - lapply(is, function(i) { - list( - index = i, - nchains = nchains, - draws = draws - ) - }) -} - - -#' @importFrom vctrs vec_restore -#' @export -vec_restore.rvar <- function(x, ...) { - if (length(x) == 0) return(rvar()) - - # need to handle the case of creating NAs from NULL entries so that - # vec_init() works properly: vec_init requires vec_slice(x, NA_integer_) - # to give you back NA values, but this breaks because we use lists as proxies. - # When using a list as a proxy, a proxy entry in `x` that is equal to NULL - # actually corresponds to an NA value due to the way that list indexing - # works: when you do something like list()[c(NA_integer_,NA_integer_)] - # you get back list(NULL, NULL), but when you do something like - # double()[c(NA_integer_,NA_integer_)] you get back c(NA, NA). - # So we have to make the NULL values be NA values to mimic vector indexing. - # N.B. could potentially do this with vec_cast as well (as long as the first - # dimension is the slicing index) - x[lengths(x) == 0] <- make_rvar_proxy(new_rvar(NA_real_)) - - # find runs where the same underlying draws are in the proxy - different_draws_from_previous <- vapply(seq_along(x)[-1], FUN.VALUE = logical(1), function(i) { - !identical(x[[i]]$draws, x[[i - 1]]$draws) || !identical(x[[i]]$nchains, x[[i - 1]]$nchains) - }) - draws_groups <- cumsum(c(TRUE, different_draws_from_previous)) - - # convert each run into a slice on an rvar and bind the resulting rvars together - groups <- split(x, draws_groups) - rvars <- lapply(groups, function(x) { - i <- vapply(x, `[[`, "index", FUN.VALUE = numeric(1)) - rvar <- new_rvar(x[[1]]$draws, .nchains = x[[1]]$nchains) - if (length(dim(rvar)) > 1) { - rvar[i, ] - } else { - rvar <- rvar[i] - .dimnames <- dimnames(rvar) - dim(rvar) <- c(length(rvar), 1) - dimnames(rvar) <- c(.dimnames, NULL) - rvar - } - }) - out <- bind_rvars(rvars, arg_exprs = NULL, deparse.level = 0, axis = 1) - - if (all(lengths(lapply(groups, function(x) dim(x[[1]]$draws))) <= 2)) { - # input was a bunch of vectors, ensure output is also a vector - .dimnames <- dimnames(out) - dim(out) <- length(out) - dimnames(out) <- .dimnames[1] - } - - # since we've already spent time calculating it, save the proxy in the cache - # - but only if the proxy only has one group (else we'd have to recalculate - # the bind above again, which is usually more expensive than generating the - # proxy itself) - if (length(groups) == 1) { - attr(out, "cache")$vec_proxy <- x - } - - out -} - -#' @export -vec_restore.rvar_factor = function(x, to, ...) { - x[lengths(x) == 0] <- make_rvar_proxy(rvar_factor(NA_integer_)) - vec_restore.rvar(x, ...) -} - -#' @export -vec_restore.rvar_ordered = function(x, to, ...) { - x[lengths(x) == 0] <- make_rvar_proxy(rvar_ordered(NA_integer_)) - vec_restore.rvar(x, ...) -} - - -# vctrs comparison proxies ------------------------------------------------ - -#' @importFrom vctrs vec_proxy_equal -#' @export -vec_proxy_equal.rvar = function(x, ...) { - # Using caching to help with algorithms that call vec_proxy_equal - # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 - - out <- attr(x, "cache")$vec_proxy_equal - if (is.null(out)) { - # proxy is not in the cache, calculate it and store it in the cache - out <- make_rvar_proxy_equal(x) - attr(x, "cache")$vec_proxy_equal <- out - } - - out -} - -#' Make a cacheable proxy for vec_proxy_equal.rvar -#' @noRd -make_rvar_proxy_equal = function(x) { - lapply(as.list(x), function(x) list( - nchains = nchains(x), - draws = draws_of(x) - )) -} - -#' @importFrom vctrs vec_proxy_compare -#' @export -vec_proxy_compare.rvar = function(x, ...) { - stop_no_call("rvar does not support vctrs::vec_compare()") -} - -#' @importFrom vctrs vec_proxy_order -#' @export -vec_proxy_order.rvar = function(x, ...) { - stop_no_call("rvar does not support vctrs::vec_order()") -} - - -# vec_ptype performance generics ------------------------------------------- - -#' @importFrom vctrs vec_ptype -#' @export -vec_ptype.rvar <- function(x, ..., x_arg = "") new_rvar() -#' @export -vec_ptype.rvar_factor <- function(x, ..., x_arg = "") new_rvar(factor()) -#' @export -vec_ptype.rvar_ordered <- function(x, ..., x_arg = "") new_rvar(ordered(NULL, levels = levels(x))) - - -# identity casts ----------------------------------------------------------- - -#' @importFrom vctrs vec_ptype2 -#' @importFrom vctrs vec_cast -#' @export -vec_ptype2.rvar.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.rvar <- function(x, to, ...) x - -#' @export -vec_ptype2.rvar_factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_factor.rvar_factor <- function(x, to, ...) x - -#' @export -vec_ptype2.rvar_ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_cast.rvar_ordered.rvar_ordered <- function(x, to, ...) x - - -# numeric and logical casts ----------------------------------------------- - -# double -> rvar -#' @export -vec_ptype2.double.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_ptype2.rvar.double <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.double <- function(x, to, ...) new_constant_rvar(x) - -# double -> rvar_factor -#' @export -vec_cast.rvar_factor.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# double -> rvar_ordered -#' @export -vec_cast.rvar_ordered.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) - -# integer -> rvar -#' @export -vec_ptype2.integer.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_ptype2.rvar.integer <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.integer <- function(x, to, ...) new_constant_rvar(x) - -# integer -> rvar_factor -#' @export -vec_cast.rvar_factor.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# integer -> rvar_ordered -#' @export -vec_cast.rvar_ordered.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) - -# logical -> rvar -#' @export -vec_ptype2.logical.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_ptype2.rvar.logical <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.logical <- function(x, to, ...) new_constant_rvar(x) - -# logical -> rvar_factor -#' @export -vec_cast.rvar_factor.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# logical -> rvar_ordered -#' @export -vec_cast.rvar_ordered.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) - - -# character casts --------------------------------------------------------- - -# rvar_[factor|ordered] -> character -#' @export -vec_cast.character.rvar <- function(x, to, ...) format(x) -#' @export -vec_cast.character.rvar_factor <- function(x, to, ...) format(x) -#' @export -vec_cast.character.rvar_ordered <- function(x, to, ...) format(x) - -# character -> rvar -#' @export -vec_cast.rvar.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# character -> rvar_factor -#' @export -vec_ptype2.character.rvar_factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_ptype2.rvar_factor.character <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_factor.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# character -> rvar_ordered -#' @export -vec_ptype2.character.rvar_ordered <- function(x, y, ...) rvar_ordered(levels = levels(y)) -#' @export -vec_ptype2.rvar_ordered.character <- function(x, y, ...) rvar_ordered(levels = levels(x)) -#' @export -vec_cast.rvar_ordered.character <- function(x, to, ...) { - old_levels <- levels(to) - new_levels <- sort(setdiff(x, levels(to))) - levels <- c(old_levels, new_levels) - ordered <- length(new_levels) == 0 - new_constant_rvar(copy_dims(x, factor(x, levels = levels, ordered = ordered))) -} - - -# factor casts --------------------------------------------------------- - -# factor -> rvar -#' @export -vec_cast.rvar.factor <- function(x, to, ...) new_constant_rvar(x) - -# factor -> rvar_factor -#' @export -vec_ptype2.factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_ptype2.rvar_factor.factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_factor.factor <- function(x, to, ...) new_constant_rvar(x) - -# factor -> rvar_ordered -#' @export -vec_ptype2.factor.rvar_ordered <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_ptype2.rvar_ordered.factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_ordered.factor <- function(x, to, ...) new_constant_rvar(x) - -# ordered -> rvar -#' @export -vec_cast.rvar.ordered <- function(x, to, ...) new_constant_rvar(x) - -# ordered -> rvar_factor -#' @export -vec_ptype2.ordered.rvar_factor <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_ptype2.rvar_factor.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_cast.rvar_factor.ordered <- function(x, to, ...) new_constant_rvar(x) - -# ordered -> rvar_ordered -#' @export -vec_ptype2.ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_ptype2.rvar_ordered.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_cast.rvar_ordered.ordered <- function(x, to, ...) new_constant_rvar(x) - - -# subtype casts ----------------------------------------------------------- - -#' @export -vec_cast.rvar_factor.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x) -#' @export -vec_cast.rvar_ordered.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) -#' @export -vec_cast.rvar_factor.rvar_ordered <- function(x, to, ...) .rvar_to_rvar_factor(x) -#' @export -vec_cast.rvar_ordered.rvar_factor <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) -#' @export -vec_cast.rvar.rvar_ordered <- function(x, to, ...) x -#' @export -vec_cast.rvar.rvar_factor <- function(x, to, ...) x - -.rvar_to_rvar_factor <- function(x, ordered = FALSE, ...) { - if ( - ...length() == 0 && - ((ordered && is_rvar_ordered(x)) || (!ordered && is_rvar_factor(x))) - ) { - # already correct type and nothing is being passed to factor() to change it - return(x) - } - - .draws <- draws_of(x) - draws_of(x) <- copy_dims(.draws, factor(.draws, ordered = ordered, ...)) - x -} - - -# casting between rvar and distribution objects --------------------------- - -#' @export -vec_ptype2.distribution.rvar <- function(x, y, ...) x - -#' @export -vec_ptype2.rvar.distribution <- function(x, y, ...) x - -#' @export -vec_cast.rvar.distribution <- function(x, to, ..., x_arg = "", to_arg = "") { - x_list <- vctrs::vec_data(x) - if (length(dim(to)) > 1 || !is_dist_sample_list(x_list)) { - vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) - } - x_rvar_list <- lapply(x_list, function(x) rvar(vctrs::field(x, 1))) - do.call(c, x_rvar_list) -} - -#' @export -vec_cast.distribution.rvar <- function(x, to, ..., x_arg = "", to_arg = "") { - if (length(dim(x)) > 1) { - vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) - } - .draws <- draws_of(x) - x_array_list <- vctrs::vec_chop(aperm(.draws, c(2, 1, seq_along(dim(.draws))[c(-1,-2)]))) - x_vector_list <- lapply(x_array_list, as.vector) - names(x_vector_list) <- names(x) - distributional::dist_sample(x_vector_list) -} - - -# helpers: casting -------------------------------------------------------- - -# create a constant rvar based on x (a double, logical, or integer) -new_constant_rvar <- function(x) { - out <- x - dim_x <- dim(x) - if (length(dim_x) == 0) { - dim(out) <- c(1, length(x)) - } else { - dim(out) <- c(1, dim_x) - dim_i <- seq_along(dim_x) - out <- copy_dimnames(x, dim_i, out, dim_i + 1) - } - new_rvar(out) -} - -# is this a list of dist_sample()s? -is_dist_sample_list <- function(x) { - all(vapply(x, inherits, logical(1), "dist_sample")) -} +#' Coerce to a random variable +#' +#' Convert `x` to an [`rvar`] object. +#' +#' @param x (multiple options) An object that can be converted to an [`rvar`], +#' such as a vector, array, or an [`rvar`] itself. +#' @template args-rvar-dim +#' @template args-rvar-dimnames +#' @param nchains (positive integer) The number of chains. The default is `1`. +#' +#' @details For objects that are already [`rvar`]s, returns them (with modified dimensions +#' if `dim` is not `NULL`). +#' +#' For numeric or logical vectors or arrays, returns an [`rvar`] with a single draw and +#' the same dimensions as `x`. This is in contrast to the [rvar()] constructor, which +#' treats the first dimension of `x` as the draws dimension. As a result, `as_rvar()` +#' is useful for creating constants. +#' +#' While `as_rvar()` attempts to pick the most suitable subtype of [`rvar`] based on the +#' type of `x` (possibly returning an [`rvar_factor`] or [`rvar_ordered`]), +#' `as_rvar_numeric()`, `as_rvar_integer()`, and `as_rvar_logical()` always coerce +#' the draws of the output [`rvar`] to be [`numeric`], [`integer`], or [`logical`] +#' (respectively), and always return a base [`rvar`], never a subtype. +#' +#' @seealso [rvar()] to construct [`rvar`]s directly. See [rdo()], [rfun()], and +#' [rvar_rng()] for higher-level interfaces for creating `rvar`s. +#' +#' @return An object of class `"rvar"` (or one of its subtypes) representing a random variable. +#' +#' @examples +#' +#' # You can use as_rvar() to create "constant" rvars (having only one draw): +#' x <- as_rvar(1) +#' x +#' +#' # Such constants can be of arbitrary shape: +#' as_rvar(1:4) +#' as_rvar(matrix(1:10, nrow = 5)) +#' as_rvar(array(1:12, dim = c(2, 3, 2))) +#' +#' # as_rvar_numeric() coerces subtypes of rvar to the base rvar type +#' y <- as_rvar_factor(c("a", "b", "c")) +#' y +#' as_rvar_numeric(y) +#' +#' @export +as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + .as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) +} +.as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL, ptype = new_rvar()) { + out <- x + + if (is.null(out)) { + out <- rvar() + } else { + out <- vec_cast(out, ptype) + } + + if (!is.null(dim)) { + dim(out) <- dim + } else if (is.null(dimnames) && is.vector(x)) { + # for non-vector-like input (matrices, arrays, etc), vec_cast should + # have already copied over the dimnames correctly. For vector-like input, + # it doesn't; so as long as the `dim` argument isn't set we can copy + # the name over + names(out) <- names(x) + } + if (!is.null(dimnames)) { + dimnames(out) <- dimnames + } + + if (!is.null(nchains)) { + .ndraws <- ndraws(out) + nchains <- as_one_integer(nchains) + check_nchains_compat_with_ndraws(nchains, .ndraws) + nchains_rvar(out) <- nchains + } + + out +} + +#' @rdname as_rvar +#' @export +as_rvar_numeric <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) + .draws <- draws_of(out) + draws_of(out) <- copy_dims(.draws, as.numeric(.draws)) + out +} + +#' @rdname as_rvar +#' @export +as_rvar_integer <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) + .draws <- draws_of(out) + draws_of(out) <- copy_dims(.draws, as.integer(.draws)) + out +} + +#' @rdname as_rvar +#' @export +as_rvar_logical <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) + .draws <- draws_of(out) + draws_of(out) <- copy_dims(.draws, as.logical(.draws)) + out +} + + +# type predicates -------------------------------------------------- + +#' Is `x` a random variable? +#' +#' Test if `x` is an [`rvar`]. +#' +#' @param x (any object) An object to test. +#' +#' @seealso [as_rvar()] to convert objects to `rvar`s. +#' +#' @return `TRUE` if `x` is an [`rvar`], `FALSE` otherwise. +#' +#' @export +is_rvar <- function(x) { + inherits(x, "rvar") +} + +#' @export +is.matrix.rvar <- function(x) { + length(dim(draws_of(x))) == 3 +} + +#' @export +is.array.rvar <- function(x) { + length(dim(draws_of(x))) > 0 +} + + +# type conversion --------------------------------------------------------- + +#' @export +as.vector.rvar <- function(x, mode = "any") { + dim(x) <- NULL + names(x) <- NULL + x +} + +#' @export +as.list.rvar <- function(x, ...) { + x_dim <- dim(x) + + if (length(x_dim) >= 2) { + is <- seq_len(x_dim[[1]]) + names(is) <- dimnames(x)[[1]] + out <- lapply(is, function(i) { + out_i <- x[i,] + .dim <- dim(out_i) + .dimnames <- dimnames(out_i) + dim(out_i) <- .dim[-1] + dimnames(out_i) <- .dimnames[-1] + out_i + }) + } else { + is <- seq_along(x) + names(is) <- dimnames(x)[[1]] + out <- lapply(is, function(i) x[[i]]) + } + out +} + +#' @export +as.array.rvar <- function(x, ...) { + out <- as.list(as.vector(x)) + dim(out) <- dim(x) + dimnames(out) <- dimnames(x) + out +} + +#' @importFrom rlang as_label +#' @export +as.data.frame.rvar <- function(x, ..., optional = FALSE) { + out <- as.data.frame.array(x, ..., optional = optional) + if (length(dim(x)) <= 1 && !optional) { + names(out) <- as_label(substitute(x)) + } + out +} + +#' @importFrom tibble as_tibble +#' @export +as_tibble.rvar <- function(x, ...) { + #default name for vectors is `value` with as_tibble + value <- x + as_tibble(as.data.frame(value, optional = FALSE), ...) +} + +# vctrs proxy / restore -------------------------------------------------------- + +invalidate_rvar_cache = function(x) { + attr(x, "cache") <- new.env(parent = emptyenv()) + x +} + +#' @importFrom vctrs vec_proxy +#' @export +vec_proxy.rvar = function(x, ...) { + # Using caching to help with algorithms that call vec_proxy + # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 + + out <- attr(x, "cache")$vec_proxy + if (is.null(out)) { + # proxy is not in the cache, calculate it and store it in the cache + out <- make_rvar_proxy(x) + attr(x, "cache")$vec_proxy <- out + } + + out +} + +#' Make a cacheable proxy for vec_proxy.rvar +#' @noRd +make_rvar_proxy = function(x) { + nchains <- nchains(x) + draws <- draws_of(x) + is <- seq_len(NROW(x)) + names(is) <- rownames(x) + lapply(is, function(i) { + list( + index = i, + nchains = nchains, + draws = draws + ) + }) +} + + +#' @importFrom vctrs vec_restore +#' @export +vec_restore.rvar <- function(x, ...) { + if (length(x) == 0) return(rvar()) + + # need to handle the case of creating NAs from NULL entries so that + # vec_init() works properly: vec_init requires vec_slice(x, NA_integer_) + # to give you back NA values, but this breaks because we use lists as proxies. + # When using a list as a proxy, a proxy entry in `x` that is equal to NULL + # actually corresponds to an NA value due to the way that list indexing + # works: when you do something like list()[c(NA_integer_,NA_integer_)] + # you get back list(NULL, NULL), but when you do something like + # double()[c(NA_integer_,NA_integer_)] you get back c(NA, NA). + # So we have to make the NULL values be NA values to mimic vector indexing. + # N.B. could potentially do this with vec_cast as well (as long as the first + # dimension is the slicing index) + x[lengths(x) == 0] <- make_rvar_proxy(new_rvar(NA_real_)) + + # find runs where the same underlying draws are in the proxy + different_draws_from_previous <- vapply(seq_along(x)[-1], FUN.VALUE = logical(1), function(i) { + !identical(x[[i]]$draws, x[[i - 1]]$draws) || !identical(x[[i]]$nchains, x[[i - 1]]$nchains) + }) + draws_groups <- cumsum(c(TRUE, different_draws_from_previous)) + + # convert each run into a slice on an rvar and bind the resulting rvars together + groups <- split(x, draws_groups) + rvars <- lapply(groups, function(x) { + i <- vapply(x, `[[`, "index", FUN.VALUE = numeric(1)) + rvar <- new_rvar(x[[1]]$draws, .nchains = x[[1]]$nchains) + if (length(dim(rvar)) > 1) { + rvar[i, ] + } else { + rvar <- rvar[i] + .dimnames <- dimnames(rvar) + dim(rvar) <- c(length(rvar), 1) + dimnames(rvar) <- c(.dimnames, NULL) + rvar + } + }) + out <- bind_rvars(rvars, arg_exprs = NULL, deparse.level = 0, axis = 1) + + if (all(lengths(lapply(groups, function(x) dim(x[[1]]$draws))) <= 2)) { + # input was a bunch of vectors, ensure output is also a vector + .dimnames <- dimnames(out) + dim(out) <- length(out) + dimnames(out) <- .dimnames[1] + } + + # since we've already spent time calculating it, save the proxy in the cache + # - but only if the proxy only has one group (else we'd have to recalculate + # the bind above again, which is usually more expensive than generating the + # proxy itself) + if (length(groups) == 1) { + attr(out, "cache")$vec_proxy <- x + } + + out +} + +#' @export +vec_restore.rvar_factor = function(x, to, ...) { + x[lengths(x) == 0] <- make_rvar_proxy(rvar_factor(NA_integer_)) + vec_restore.rvar(x, ...) +} + +#' @export +vec_restore.rvar_ordered = function(x, to, ...) { + x[lengths(x) == 0] <- make_rvar_proxy(rvar_ordered(NA_integer_)) + vec_restore.rvar(x, ...) +} + + +# vctrs comparison proxies ------------------------------------------------ + +#' @importFrom vctrs vec_proxy_equal +#' @export +vec_proxy_equal.rvar = function(x, ...) { + # Using caching to help with algorithms that call vec_proxy_equal + # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 + + out <- attr(x, "cache")$vec_proxy_equal + if (is.null(out)) { + # proxy is not in the cache, calculate it and store it in the cache + out <- make_rvar_proxy_equal(x) + attr(x, "cache")$vec_proxy_equal <- out + } + + out +} + +#' Make a cacheable proxy for vec_proxy_equal.rvar +#' @noRd +make_rvar_proxy_equal = function(x) { + lapply(as.list(x), function(x) list( + nchains = nchains(x), + draws = draws_of(x) + )) +} + +#' @importFrom vctrs vec_proxy_compare +#' @export +vec_proxy_compare.rvar = function(x, ...) { + stop_no_call("rvar does not support vctrs::vec_compare()") +} + +#' @importFrom vctrs vec_proxy_order +#' @export +vec_proxy_order.rvar = function(x, ...) { + stop_no_call("rvar does not support vctrs::vec_order()") +} + + +# vec_ptype performance generics ------------------------------------------- + +#' @importFrom vctrs vec_ptype +#' @export +vec_ptype.rvar <- function(x, ..., x_arg = "") new_rvar() +#' @export +vec_ptype.rvar_factor <- function(x, ..., x_arg = "") new_rvar(factor()) +#' @export +vec_ptype.rvar_ordered <- function(x, ..., x_arg = "") new_rvar(ordered(NULL, levels = levels(x))) + + +# identity casts ----------------------------------------------------------- + +#' @importFrom vctrs vec_ptype2 +#' @importFrom vctrs vec_cast +#' @export +vec_ptype2.rvar.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.rvar <- function(x, to, ...) x + +#' @export +vec_ptype2.rvar_factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_factor.rvar_factor <- function(x, to, ...) x + +#' @export +vec_ptype2.rvar_ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_cast.rvar_ordered.rvar_ordered <- function(x, to, ...) x + + +# numeric and logical casts ----------------------------------------------- + +# double -> rvar +#' @export +vec_ptype2.double.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_ptype2.rvar.double <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.double <- function(x, to, ...) new_constant_rvar(x) + +# double -> rvar_factor +#' @export +vec_cast.rvar_factor.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# double -> rvar_ordered +#' @export +vec_cast.rvar_ordered.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) + +# integer -> rvar +#' @export +vec_ptype2.integer.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_ptype2.rvar.integer <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.integer <- function(x, to, ...) new_constant_rvar(x) + +# integer -> rvar_factor +#' @export +vec_cast.rvar_factor.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# integer -> rvar_ordered +#' @export +vec_cast.rvar_ordered.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) + +# logical -> rvar +#' @export +vec_ptype2.logical.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_ptype2.rvar.logical <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.logical <- function(x, to, ...) new_constant_rvar(x) + +# logical -> rvar_factor +#' @export +vec_cast.rvar_factor.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# logical -> rvar_ordered +#' @export +vec_cast.rvar_ordered.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) + + +# character casts --------------------------------------------------------- + +# rvar_[factor|ordered] -> character +#' @export +vec_cast.character.rvar <- function(x, to, ...) format(x) +#' @export +vec_cast.character.rvar_factor <- function(x, to, ...) format(x) +#' @export +vec_cast.character.rvar_ordered <- function(x, to, ...) format(x) + +# character -> rvar +#' @export +vec_cast.rvar.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# character -> rvar_factor +#' @export +vec_ptype2.character.rvar_factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_ptype2.rvar_factor.character <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_factor.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# character -> rvar_ordered +#' @export +vec_ptype2.character.rvar_ordered <- function(x, y, ...) rvar_ordered(levels = levels(y)) +#' @export +vec_ptype2.rvar_ordered.character <- function(x, y, ...) rvar_ordered(levels = levels(x)) +#' @export +vec_cast.rvar_ordered.character <- function(x, to, ...) { + old_levels <- levels(to) + new_levels <- sort(setdiff(x, levels(to))) + levels <- c(old_levels, new_levels) + ordered <- length(new_levels) == 0 + new_constant_rvar(copy_dims(x, factor(x, levels = levels, ordered = ordered))) +} + + +# factor casts --------------------------------------------------------- + +# factor -> rvar +#' @export +vec_cast.rvar.factor <- function(x, to, ...) new_constant_rvar(x) + +# factor -> rvar_factor +#' @export +vec_ptype2.factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_ptype2.rvar_factor.factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_factor.factor <- function(x, to, ...) new_constant_rvar(x) + +# factor -> rvar_ordered +#' @export +vec_ptype2.factor.rvar_ordered <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_ptype2.rvar_ordered.factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_ordered.factor <- function(x, to, ...) new_constant_rvar(x) + +# ordered -> rvar +#' @export +vec_cast.rvar.ordered <- function(x, to, ...) new_constant_rvar(x) + +# ordered -> rvar_factor +#' @export +vec_ptype2.ordered.rvar_factor <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_ptype2.rvar_factor.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_cast.rvar_factor.ordered <- function(x, to, ...) new_constant_rvar(x) + +# ordered -> rvar_ordered +#' @export +vec_ptype2.ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_ptype2.rvar_ordered.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_cast.rvar_ordered.ordered <- function(x, to, ...) new_constant_rvar(x) + + +# subtype casts ----------------------------------------------------------- + +#' @export +vec_cast.rvar_factor.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x) +#' @export +vec_cast.rvar_ordered.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) +#' @export +vec_cast.rvar_factor.rvar_ordered <- function(x, to, ...) .rvar_to_rvar_factor(x) +#' @export +vec_cast.rvar_ordered.rvar_factor <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) +#' @export +vec_cast.rvar.rvar_ordered <- function(x, to, ...) x +#' @export +vec_cast.rvar.rvar_factor <- function(x, to, ...) x + +.rvar_to_rvar_factor <- function(x, ordered = FALSE, ...) { + if ( + ...length() == 0 && + ((ordered && is_rvar_ordered(x)) || (!ordered && is_rvar_factor(x))) + ) { + # already correct type and nothing is being passed to factor() to change it + return(x) + } + + .draws <- draws_of(x) + draws_of(x) <- copy_dims(.draws, factor(.draws, ordered = ordered, ...)) + x +} + + +# casting between rvar and distribution objects --------------------------- + +#' @export +vec_ptype2.distribution.rvar <- function(x, y, ...) x + +#' @export +vec_ptype2.rvar.distribution <- function(x, y, ...) x + +#' @export +vec_cast.rvar.distribution <- function(x, to, ..., x_arg = "", to_arg = "") { + x_list <- vctrs::vec_data(x) + if (length(dim(to)) > 1 || !is_dist_sample_list(x_list)) { + vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) + } + x_rvar_list <- lapply(x_list, function(x) rvar(vctrs::field(x, 1))) + do.call(c, x_rvar_list) +} + +#' @export +vec_cast.distribution.rvar <- function(x, to, ..., x_arg = "", to_arg = "") { + if (length(dim(x)) > 1) { + vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) + } + .draws <- draws_of(x) + x_array_list <- vctrs::vec_chop(aperm(.draws, c(2, 1, seq_along(dim(.draws))[c(-1,-2)]))) + x_vector_list <- lapply(x_array_list, as.vector) + names(x_vector_list) <- names(x) + distributional::dist_sample(x_vector_list) +} + + +# helpers: casting -------------------------------------------------------- + +# create a constant rvar based on x (a double, logical, or integer) +new_constant_rvar <- function(x) { + out <- x + dim_x <- dim(x) + if (length(dim_x) == 0) { + dim(out) <- c(1, length(x)) + } else { + dim(out) <- c(1, dim_x) + dim_i <- seq_along(dim_x) + out <- copy_dimnames(x, dim_i, out, dim_i + 1) + } + new_rvar(out) +} + +# is this a list of dist_sample()s? +is_dist_sample_list <- function(x) { + all(vapply(x, inherits, logical(1), "dist_sample")) +} diff --git a/tests/testthat/test-rvar-cast.R b/tests/testthat/test-rvar-cast.R index 384cb05e..1ad5a419 100755 --- a/tests/testthat/test-rvar-cast.R +++ b/tests/testthat/test-rvar-cast.R @@ -259,6 +259,17 @@ test_that("as.vector works", { expect_equal(as.vector(x), rvar(array(1:12, dim = c(2, 6)))) }) +test_that("base apply works on multidimensional rvars", { + set.seed(3456) + x <- rvar_rng(rnorm, 24, mean = 1:24) + dim(x) <- c(2, 3, 4) + + expect_equal( + apply(x, c(1, 2), length) |> unname(), + array(4L, dim = c(2, 3)) + ) +}) + test_that("as.data.frame and as_tibble work on rvars", { x1 = rvar(array(1:9, dim = c(3,3)), dimnames = list(A = paste0("a", 1:3)) From d3462dbbdf1ed84120a39a9f6ac17311fb798423 Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 20:40:54 -0700 Subject: [PATCH 2/8] Normed line endings --- .gitattributes | 4 + .github/.gitignore | 2 +- .github/workflows/test-coverage.yaml | 128 +-- DESCRIPTION | 2 +- R/rvar-cast.R | 1180 ++++++++++++------------ codecov.yml | 28 +- man/as_rvar_factor.Rd | 3 + man/draws.Rd | 12 +- man/draws_array.Rd | 10 +- man/draws_df.Rd | 10 +- man/draws_list.Rd | 10 +- man/draws_matrix.Rd | 10 +- man/draws_rvars.Rd | 10 +- man/ess_basic.Rd | 28 +- man/ess_bulk.Rd | 28 +- man/ess_quantile.Rd | 28 +- man/ess_sd.Rd | 28 +- man/ess_tail.Rd | 28 +- man/extract_list_of_variable_arrays.Rd | 8 +- man/extract_variable.Rd | 8 +- man/extract_variable_array.Rd | 8 +- man/extract_variable_matrix.Rd | 8 +- man/for_each_draw.Rd | 2 +- man/gpdfit.Rd | 10 +- man/mcse_mean.Rd | 28 +- man/mcse_quantile.Rd | 28 +- man/mcse_sd.Rd | 28 +- man/pareto_diags.Rd | 28 +- man/pareto_khat.Rd | 28 +- man/posterior-package.Rd | 1 + man/print.draws_summary.Rd | 2 +- man/print.rvar.Rd | 2 +- man/ps_convergence_rate.Rd | 10 +- man/ps_khat_threshold.Rd | 10 +- man/ps_min_ss.Rd | 10 +- man/ps_tail_length.Rd | 10 +- man/rdo.Rd | 8 +- man/reexports.Rd | 2 +- man/rfun.Rd | 6 +- man/rhat.Rd | 28 +- man/rhat_basic.Rd | 28 +- man/rhat_nested.Rd | 28 +- man/rstar.Rd | 28 +- man/rvar-summaries-over-draws.Rd | 4 +- man/rvar-summaries-within-draws.Rd | 4 +- man/rvar_factor.Rd | 3 + man/rvar_is_finite.Rd | 2 +- man/rvar_rng.Rd | 6 +- 48 files changed, 968 insertions(+), 957 deletions(-) create mode 100644 .gitattributes diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..d406e527 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,4 @@ +* text=auto eol=lf +*.rda binary +*.RData binary +*.rds binary diff --git a/.github/.gitignore b/.github/.gitignore index d3fc626f..2d19fc76 100644 --- a/.github/.gitignore +++ b/.github/.gitignore @@ -1 +1 @@ -*.html +*.html diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 6c52266c..d6b2c38f 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -1,64 +1,64 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, master] - pull_request: - -name: test-coverage.yaml - -permissions: - contents: read - id-token: write - -jobs: - test-coverage: - runs-on: ubuntu-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v6 - - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::covr, any::xml2 - needs: coverage - - - name: Test coverage - run: | - cov <- covr::package_coverage( - quiet = FALSE, - clean = FALSE, - install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") - ) - print(cov) - covr::to_cobertura(cov) - shell: Rscript {0} - - - uses: codecov/codecov-action@v7 - with: - # Fail if error if not on PR, or if on PR and token is given - fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} - files: ./cobertura.xml - plugins: noop - disable_search: true - use_oidc: true - - - name: Show testthat output - if: always() - run: | - ## -------------------------------------------------------------------- - find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true - shell: bash - - - name: Upload test results - if: failure() - uses: actions/upload-artifact@v7 - with: - name: coverage-test-failures - path: ${{ runner.temp }}/package +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + +name: test-coverage.yaml + +permissions: + contents: read + id-token: write + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v6 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr, any::xml2 + needs: coverage + + - name: Test coverage + run: | + cov <- covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + print(cov) + covr::to_cobertura(cov) + shell: Rscript {0} + + - uses: codecov/codecov-action@v7 + with: + # Fail if error if not on PR, or if on PR and token is given + fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} + files: ./cobertura.xml + plugins: noop + disable_search: true + use_oidc: true + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v7 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/DESCRIPTION b/DESCRIPTION index 068f9bcd..06910234 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -59,5 +59,5 @@ LazyData: false URL: https://mc-stan.org/posterior/, https://discourse.mc-stan.org/ BugReports: https://github.com/stan-dev/posterior/issues Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 VignetteBuilder: knitr +Config/roxygen2/version: 8.0.0 diff --git a/R/rvar-cast.R b/R/rvar-cast.R index d746f36b..5236c109 100755 --- a/R/rvar-cast.R +++ b/R/rvar-cast.R @@ -1,590 +1,590 @@ -#' Coerce to a random variable -#' -#' Convert `x` to an [`rvar`] object. -#' -#' @param x (multiple options) An object that can be converted to an [`rvar`], -#' such as a vector, array, or an [`rvar`] itself. -#' @template args-rvar-dim -#' @template args-rvar-dimnames -#' @param nchains (positive integer) The number of chains. The default is `1`. -#' -#' @details For objects that are already [`rvar`]s, returns them (with modified dimensions -#' if `dim` is not `NULL`). -#' -#' For numeric or logical vectors or arrays, returns an [`rvar`] with a single draw and -#' the same dimensions as `x`. This is in contrast to the [rvar()] constructor, which -#' treats the first dimension of `x` as the draws dimension. As a result, `as_rvar()` -#' is useful for creating constants. -#' -#' While `as_rvar()` attempts to pick the most suitable subtype of [`rvar`] based on the -#' type of `x` (possibly returning an [`rvar_factor`] or [`rvar_ordered`]), -#' `as_rvar_numeric()`, `as_rvar_integer()`, and `as_rvar_logical()` always coerce -#' the draws of the output [`rvar`] to be [`numeric`], [`integer`], or [`logical`] -#' (respectively), and always return a base [`rvar`], never a subtype. -#' -#' @seealso [rvar()] to construct [`rvar`]s directly. See [rdo()], [rfun()], and -#' [rvar_rng()] for higher-level interfaces for creating `rvar`s. -#' -#' @return An object of class `"rvar"` (or one of its subtypes) representing a random variable. -#' -#' @examples -#' -#' # You can use as_rvar() to create "constant" rvars (having only one draw): -#' x <- as_rvar(1) -#' x -#' -#' # Such constants can be of arbitrary shape: -#' as_rvar(1:4) -#' as_rvar(matrix(1:10, nrow = 5)) -#' as_rvar(array(1:12, dim = c(2, 3, 2))) -#' -#' # as_rvar_numeric() coerces subtypes of rvar to the base rvar type -#' y <- as_rvar_factor(c("a", "b", "c")) -#' y -#' as_rvar_numeric(y) -#' -#' @export -as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - .as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) -} -.as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL, ptype = new_rvar()) { - out <- x - - if (is.null(out)) { - out <- rvar() - } else { - out <- vec_cast(out, ptype) - } - - if (!is.null(dim)) { - dim(out) <- dim - } else if (is.null(dimnames) && is.vector(x)) { - # for non-vector-like input (matrices, arrays, etc), vec_cast should - # have already copied over the dimnames correctly. For vector-like input, - # it doesn't; so as long as the `dim` argument isn't set we can copy - # the name over - names(out) <- names(x) - } - if (!is.null(dimnames)) { - dimnames(out) <- dimnames - } - - if (!is.null(nchains)) { - .ndraws <- ndraws(out) - nchains <- as_one_integer(nchains) - check_nchains_compat_with_ndraws(nchains, .ndraws) - nchains_rvar(out) <- nchains - } - - out -} - -#' @rdname as_rvar -#' @export -as_rvar_numeric <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) - .draws <- draws_of(out) - draws_of(out) <- copy_dims(.draws, as.numeric(.draws)) - out -} - -#' @rdname as_rvar -#' @export -as_rvar_integer <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) - .draws <- draws_of(out) - draws_of(out) <- copy_dims(.draws, as.integer(.draws)) - out -} - -#' @rdname as_rvar -#' @export -as_rvar_logical <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { - out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) - .draws <- draws_of(out) - draws_of(out) <- copy_dims(.draws, as.logical(.draws)) - out -} - - -# type predicates -------------------------------------------------- - -#' Is `x` a random variable? -#' -#' Test if `x` is an [`rvar`]. -#' -#' @param x (any object) An object to test. -#' -#' @seealso [as_rvar()] to convert objects to `rvar`s. -#' -#' @return `TRUE` if `x` is an [`rvar`], `FALSE` otherwise. -#' -#' @export -is_rvar <- function(x) { - inherits(x, "rvar") -} - -#' @export -is.matrix.rvar <- function(x) { - length(dim(draws_of(x))) == 3 -} - -#' @export -is.array.rvar <- function(x) { - length(dim(draws_of(x))) > 0 -} - - -# type conversion --------------------------------------------------------- - -#' @export -as.vector.rvar <- function(x, mode = "any") { - dim(x) <- NULL - names(x) <- NULL - x -} - -#' @export -as.list.rvar <- function(x, ...) { - x_dim <- dim(x) - - if (length(x_dim) >= 2) { - is <- seq_len(x_dim[[1]]) - names(is) <- dimnames(x)[[1]] - out <- lapply(is, function(i) { - out_i <- x[i,] - .dim <- dim(out_i) - .dimnames <- dimnames(out_i) - dim(out_i) <- .dim[-1] - dimnames(out_i) <- .dimnames[-1] - out_i - }) - } else { - is <- seq_along(x) - names(is) <- dimnames(x)[[1]] - out <- lapply(is, function(i) x[[i]]) - } - out -} - -#' @export -as.array.rvar <- function(x, ...) { - out <- as.list(as.vector(x)) - dim(out) <- dim(x) - dimnames(out) <- dimnames(x) - out -} - -#' @importFrom rlang as_label -#' @export -as.data.frame.rvar <- function(x, ..., optional = FALSE) { - out <- as.data.frame.array(x, ..., optional = optional) - if (length(dim(x)) <= 1 && !optional) { - names(out) <- as_label(substitute(x)) - } - out -} - -#' @importFrom tibble as_tibble -#' @export -as_tibble.rvar <- function(x, ...) { - #default name for vectors is `value` with as_tibble - value <- x - as_tibble(as.data.frame(value, optional = FALSE), ...) -} - -# vctrs proxy / restore -------------------------------------------------------- - -invalidate_rvar_cache = function(x) { - attr(x, "cache") <- new.env(parent = emptyenv()) - x -} - -#' @importFrom vctrs vec_proxy -#' @export -vec_proxy.rvar = function(x, ...) { - # Using caching to help with algorithms that call vec_proxy - # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 - - out <- attr(x, "cache")$vec_proxy - if (is.null(out)) { - # proxy is not in the cache, calculate it and store it in the cache - out <- make_rvar_proxy(x) - attr(x, "cache")$vec_proxy <- out - } - - out -} - -#' Make a cacheable proxy for vec_proxy.rvar -#' @noRd -make_rvar_proxy = function(x) { - nchains <- nchains(x) - draws <- draws_of(x) - is <- seq_len(NROW(x)) - names(is) <- rownames(x) - lapply(is, function(i) { - list( - index = i, - nchains = nchains, - draws = draws - ) - }) -} - - -#' @importFrom vctrs vec_restore -#' @export -vec_restore.rvar <- function(x, ...) { - if (length(x) == 0) return(rvar()) - - # need to handle the case of creating NAs from NULL entries so that - # vec_init() works properly: vec_init requires vec_slice(x, NA_integer_) - # to give you back NA values, but this breaks because we use lists as proxies. - # When using a list as a proxy, a proxy entry in `x` that is equal to NULL - # actually corresponds to an NA value due to the way that list indexing - # works: when you do something like list()[c(NA_integer_,NA_integer_)] - # you get back list(NULL, NULL), but when you do something like - # double()[c(NA_integer_,NA_integer_)] you get back c(NA, NA). - # So we have to make the NULL values be NA values to mimic vector indexing. - # N.B. could potentially do this with vec_cast as well (as long as the first - # dimension is the slicing index) - x[lengths(x) == 0] <- make_rvar_proxy(new_rvar(NA_real_)) - - # find runs where the same underlying draws are in the proxy - different_draws_from_previous <- vapply(seq_along(x)[-1], FUN.VALUE = logical(1), function(i) { - !identical(x[[i]]$draws, x[[i - 1]]$draws) || !identical(x[[i]]$nchains, x[[i - 1]]$nchains) - }) - draws_groups <- cumsum(c(TRUE, different_draws_from_previous)) - - # convert each run into a slice on an rvar and bind the resulting rvars together - groups <- split(x, draws_groups) - rvars <- lapply(groups, function(x) { - i <- vapply(x, `[[`, "index", FUN.VALUE = numeric(1)) - rvar <- new_rvar(x[[1]]$draws, .nchains = x[[1]]$nchains) - if (length(dim(rvar)) > 1) { - rvar[i, ] - } else { - rvar <- rvar[i] - .dimnames <- dimnames(rvar) - dim(rvar) <- c(length(rvar), 1) - dimnames(rvar) <- c(.dimnames, NULL) - rvar - } - }) - out <- bind_rvars(rvars, arg_exprs = NULL, deparse.level = 0, axis = 1) - - if (all(lengths(lapply(groups, function(x) dim(x[[1]]$draws))) <= 2)) { - # input was a bunch of vectors, ensure output is also a vector - .dimnames <- dimnames(out) - dim(out) <- length(out) - dimnames(out) <- .dimnames[1] - } - - # since we've already spent time calculating it, save the proxy in the cache - # - but only if the proxy only has one group (else we'd have to recalculate - # the bind above again, which is usually more expensive than generating the - # proxy itself) - if (length(groups) == 1) { - attr(out, "cache")$vec_proxy <- x - } - - out -} - -#' @export -vec_restore.rvar_factor = function(x, to, ...) { - x[lengths(x) == 0] <- make_rvar_proxy(rvar_factor(NA_integer_)) - vec_restore.rvar(x, ...) -} - -#' @export -vec_restore.rvar_ordered = function(x, to, ...) { - x[lengths(x) == 0] <- make_rvar_proxy(rvar_ordered(NA_integer_)) - vec_restore.rvar(x, ...) -} - - -# vctrs comparison proxies ------------------------------------------------ - -#' @importFrom vctrs vec_proxy_equal -#' @export -vec_proxy_equal.rvar = function(x, ...) { - # Using caching to help with algorithms that call vec_proxy_equal - # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 - - out <- attr(x, "cache")$vec_proxy_equal - if (is.null(out)) { - # proxy is not in the cache, calculate it and store it in the cache - out <- make_rvar_proxy_equal(x) - attr(x, "cache")$vec_proxy_equal <- out - } - - out -} - -#' Make a cacheable proxy for vec_proxy_equal.rvar -#' @noRd -make_rvar_proxy_equal = function(x) { - lapply(as.list(x), function(x) list( - nchains = nchains(x), - draws = draws_of(x) - )) -} - -#' @importFrom vctrs vec_proxy_compare -#' @export -vec_proxy_compare.rvar = function(x, ...) { - stop_no_call("rvar does not support vctrs::vec_compare()") -} - -#' @importFrom vctrs vec_proxy_order -#' @export -vec_proxy_order.rvar = function(x, ...) { - stop_no_call("rvar does not support vctrs::vec_order()") -} - - -# vec_ptype performance generics ------------------------------------------- - -#' @importFrom vctrs vec_ptype -#' @export -vec_ptype.rvar <- function(x, ..., x_arg = "") new_rvar() -#' @export -vec_ptype.rvar_factor <- function(x, ..., x_arg = "") new_rvar(factor()) -#' @export -vec_ptype.rvar_ordered <- function(x, ..., x_arg = "") new_rvar(ordered(NULL, levels = levels(x))) - - -# identity casts ----------------------------------------------------------- - -#' @importFrom vctrs vec_ptype2 -#' @importFrom vctrs vec_cast -#' @export -vec_ptype2.rvar.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.rvar <- function(x, to, ...) x - -#' @export -vec_ptype2.rvar_factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_factor.rvar_factor <- function(x, to, ...) x - -#' @export -vec_ptype2.rvar_ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_cast.rvar_ordered.rvar_ordered <- function(x, to, ...) x - - -# numeric and logical casts ----------------------------------------------- - -# double -> rvar -#' @export -vec_ptype2.double.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_ptype2.rvar.double <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.double <- function(x, to, ...) new_constant_rvar(x) - -# double -> rvar_factor -#' @export -vec_cast.rvar_factor.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# double -> rvar_ordered -#' @export -vec_cast.rvar_ordered.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) - -# integer -> rvar -#' @export -vec_ptype2.integer.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_ptype2.rvar.integer <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.integer <- function(x, to, ...) new_constant_rvar(x) - -# integer -> rvar_factor -#' @export -vec_cast.rvar_factor.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# integer -> rvar_ordered -#' @export -vec_cast.rvar_ordered.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) - -# logical -> rvar -#' @export -vec_ptype2.logical.rvar <- function(x, y, ...) new_rvar() -#' @export -vec_ptype2.rvar.logical <- function(x, y, ...) new_rvar() -#' @export -vec_cast.rvar.logical <- function(x, to, ...) new_constant_rvar(x) - -# logical -> rvar_factor -#' @export -vec_cast.rvar_factor.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# logical -> rvar_ordered -#' @export -vec_cast.rvar_ordered.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) - - -# character casts --------------------------------------------------------- - -# rvar_[factor|ordered] -> character -#' @export -vec_cast.character.rvar <- function(x, to, ...) format(x) -#' @export -vec_cast.character.rvar_factor <- function(x, to, ...) format(x) -#' @export -vec_cast.character.rvar_ordered <- function(x, to, ...) format(x) - -# character -> rvar -#' @export -vec_cast.rvar.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# character -> rvar_factor -#' @export -vec_ptype2.character.rvar_factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_ptype2.rvar_factor.character <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_factor.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) - -# character -> rvar_ordered -#' @export -vec_ptype2.character.rvar_ordered <- function(x, y, ...) rvar_ordered(levels = levels(y)) -#' @export -vec_ptype2.rvar_ordered.character <- function(x, y, ...) rvar_ordered(levels = levels(x)) -#' @export -vec_cast.rvar_ordered.character <- function(x, to, ...) { - old_levels <- levels(to) - new_levels <- sort(setdiff(x, levels(to))) - levels <- c(old_levels, new_levels) - ordered <- length(new_levels) == 0 - new_constant_rvar(copy_dims(x, factor(x, levels = levels, ordered = ordered))) -} - - -# factor casts --------------------------------------------------------- - -# factor -> rvar -#' @export -vec_cast.rvar.factor <- function(x, to, ...) new_constant_rvar(x) - -# factor -> rvar_factor -#' @export -vec_ptype2.factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_ptype2.rvar_factor.factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_factor.factor <- function(x, to, ...) new_constant_rvar(x) - -# factor -> rvar_ordered -#' @export -vec_ptype2.factor.rvar_ordered <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_ptype2.rvar_ordered.factor <- function(x, y, ...) new_rvar(factor()) -#' @export -vec_cast.rvar_ordered.factor <- function(x, to, ...) new_constant_rvar(x) - -# ordered -> rvar -#' @export -vec_cast.rvar.ordered <- function(x, to, ...) new_constant_rvar(x) - -# ordered -> rvar_factor -#' @export -vec_ptype2.ordered.rvar_factor <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_ptype2.rvar_factor.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_cast.rvar_factor.ordered <- function(x, to, ...) new_constant_rvar(x) - -# ordered -> rvar_ordered -#' @export -vec_ptype2.ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_ptype2.rvar_ordered.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) -#' @export -vec_cast.rvar_ordered.ordered <- function(x, to, ...) new_constant_rvar(x) - - -# subtype casts ----------------------------------------------------------- - -#' @export -vec_cast.rvar_factor.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x) -#' @export -vec_cast.rvar_ordered.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) -#' @export -vec_cast.rvar_factor.rvar_ordered <- function(x, to, ...) .rvar_to_rvar_factor(x) -#' @export -vec_cast.rvar_ordered.rvar_factor <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) -#' @export -vec_cast.rvar.rvar_ordered <- function(x, to, ...) x -#' @export -vec_cast.rvar.rvar_factor <- function(x, to, ...) x - -.rvar_to_rvar_factor <- function(x, ordered = FALSE, ...) { - if ( - ...length() == 0 && - ((ordered && is_rvar_ordered(x)) || (!ordered && is_rvar_factor(x))) - ) { - # already correct type and nothing is being passed to factor() to change it - return(x) - } - - .draws <- draws_of(x) - draws_of(x) <- copy_dims(.draws, factor(.draws, ordered = ordered, ...)) - x -} - - -# casting between rvar and distribution objects --------------------------- - -#' @export -vec_ptype2.distribution.rvar <- function(x, y, ...) x - -#' @export -vec_ptype2.rvar.distribution <- function(x, y, ...) x - -#' @export -vec_cast.rvar.distribution <- function(x, to, ..., x_arg = "", to_arg = "") { - x_list <- vctrs::vec_data(x) - if (length(dim(to)) > 1 || !is_dist_sample_list(x_list)) { - vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) - } - x_rvar_list <- lapply(x_list, function(x) rvar(vctrs::field(x, 1))) - do.call(c, x_rvar_list) -} - -#' @export -vec_cast.distribution.rvar <- function(x, to, ..., x_arg = "", to_arg = "") { - if (length(dim(x)) > 1) { - vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) - } - .draws <- draws_of(x) - x_array_list <- vctrs::vec_chop(aperm(.draws, c(2, 1, seq_along(dim(.draws))[c(-1,-2)]))) - x_vector_list <- lapply(x_array_list, as.vector) - names(x_vector_list) <- names(x) - distributional::dist_sample(x_vector_list) -} - - -# helpers: casting -------------------------------------------------------- - -# create a constant rvar based on x (a double, logical, or integer) -new_constant_rvar <- function(x) { - out <- x - dim_x <- dim(x) - if (length(dim_x) == 0) { - dim(out) <- c(1, length(x)) - } else { - dim(out) <- c(1, dim_x) - dim_i <- seq_along(dim_x) - out <- copy_dimnames(x, dim_i, out, dim_i + 1) - } - new_rvar(out) -} - -# is this a list of dist_sample()s? -is_dist_sample_list <- function(x) { - all(vapply(x, inherits, logical(1), "dist_sample")) -} +#' Coerce to a random variable +#' +#' Convert `x` to an [`rvar`] object. +#' +#' @param x (multiple options) An object that can be converted to an [`rvar`], +#' such as a vector, array, or an [`rvar`] itself. +#' @template args-rvar-dim +#' @template args-rvar-dimnames +#' @param nchains (positive integer) The number of chains. The default is `1`. +#' +#' @details For objects that are already [`rvar`]s, returns them (with modified dimensions +#' if `dim` is not `NULL`). +#' +#' For numeric or logical vectors or arrays, returns an [`rvar`] with a single draw and +#' the same dimensions as `x`. This is in contrast to the [rvar()] constructor, which +#' treats the first dimension of `x` as the draws dimension. As a result, `as_rvar()` +#' is useful for creating constants. +#' +#' While `as_rvar()` attempts to pick the most suitable subtype of [`rvar`] based on the +#' type of `x` (possibly returning an [`rvar_factor`] or [`rvar_ordered`]), +#' `as_rvar_numeric()`, `as_rvar_integer()`, and `as_rvar_logical()` always coerce +#' the draws of the output [`rvar`] to be [`numeric`], [`integer`], or [`logical`] +#' (respectively), and always return a base [`rvar`], never a subtype. +#' +#' @seealso [rvar()] to construct [`rvar`]s directly. See [rdo()], [rfun()], and +#' [rvar_rng()] for higher-level interfaces for creating `rvar`s. +#' +#' @return An object of class `"rvar"` (or one of its subtypes) representing a random variable. +#' +#' @examples +#' +#' # You can use as_rvar() to create "constant" rvars (having only one draw): +#' x <- as_rvar(1) +#' x +#' +#' # Such constants can be of arbitrary shape: +#' as_rvar(1:4) +#' as_rvar(matrix(1:10, nrow = 5)) +#' as_rvar(array(1:12, dim = c(2, 3, 2))) +#' +#' # as_rvar_numeric() coerces subtypes of rvar to the base rvar type +#' y <- as_rvar_factor(c("a", "b", "c")) +#' y +#' as_rvar_numeric(y) +#' +#' @export +as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + .as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) +} +.as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL, ptype = new_rvar()) { + out <- x + + if (is.null(out)) { + out <- rvar() + } else { + out <- vec_cast(out, ptype) + } + + if (!is.null(dim)) { + dim(out) <- dim + } else if (is.null(dimnames) && is.vector(x)) { + # for non-vector-like input (matrices, arrays, etc), vec_cast should + # have already copied over the dimnames correctly. For vector-like input, + # it doesn't; so as long as the `dim` argument isn't set we can copy + # the name over + names(out) <- names(x) + } + if (!is.null(dimnames)) { + dimnames(out) <- dimnames + } + + if (!is.null(nchains)) { + .ndraws <- ndraws(out) + nchains <- as_one_integer(nchains) + check_nchains_compat_with_ndraws(nchains, .ndraws) + nchains_rvar(out) <- nchains + } + + out +} + +#' @rdname as_rvar +#' @export +as_rvar_numeric <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) + .draws <- draws_of(out) + draws_of(out) <- copy_dims(.draws, as.numeric(.draws)) + out +} + +#' @rdname as_rvar +#' @export +as_rvar_integer <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) + .draws <- draws_of(out) + draws_of(out) <- copy_dims(.draws, as.integer(.draws)) + out +} + +#' @rdname as_rvar +#' @export +as_rvar_logical <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { + out <- as_rvar(x, dim = dim, dimnames = dimnames, nchains = nchains) + .draws <- draws_of(out) + draws_of(out) <- copy_dims(.draws, as.logical(.draws)) + out +} + + +# type predicates -------------------------------------------------- + +#' Is `x` a random variable? +#' +#' Test if `x` is an [`rvar`]. +#' +#' @param x (any object) An object to test. +#' +#' @seealso [as_rvar()] to convert objects to `rvar`s. +#' +#' @return `TRUE` if `x` is an [`rvar`], `FALSE` otherwise. +#' +#' @export +is_rvar <- function(x) { + inherits(x, "rvar") +} + +#' @export +is.matrix.rvar <- function(x) { + length(dim(draws_of(x))) == 3 +} + +#' @export +is.array.rvar <- function(x) { + length(dim(draws_of(x))) > 0 +} + + +# type conversion --------------------------------------------------------- + +#' @export +as.vector.rvar <- function(x, mode = "any") { + dim(x) <- NULL + names(x) <- NULL + x +} + +#' @export +as.list.rvar <- function(x, ...) { + x_dim <- dim(x) + + if (length(x_dim) >= 2) { + is <- seq_len(x_dim[[1]]) + names(is) <- dimnames(x)[[1]] + out <- lapply(is, function(i) { + out_i <- x[i,] + .dim <- dim(out_i) + .dimnames <- dimnames(out_i) + dim(out_i) <- .dim[-1] + dimnames(out_i) <- .dimnames[-1] + out_i + }) + } else { + is <- seq_along(x) + names(is) <- dimnames(x)[[1]] + out <- lapply(is, function(i) x[[i]]) + } + out +} + +#' @export +as.array.rvar <- function(x, ...) { + out <- as.list(as.vector(x)) + dim(out) <- dim(x) + dimnames(out) <- dimnames(x) + out +} + +#' @importFrom rlang as_label +#' @export +as.data.frame.rvar <- function(x, ..., optional = FALSE) { + out <- as.data.frame.array(x, ..., optional = optional) + if (length(dim(x)) <= 1 && !optional) { + names(out) <- as_label(substitute(x)) + } + out +} + +#' @importFrom tibble as_tibble +#' @export +as_tibble.rvar <- function(x, ...) { + #default name for vectors is `value` with as_tibble + value <- x + as_tibble(as.data.frame(value, optional = FALSE), ...) +} + +# vctrs proxy / restore -------------------------------------------------------- + +invalidate_rvar_cache = function(x) { + attr(x, "cache") <- new.env(parent = emptyenv()) + x +} + +#' @importFrom vctrs vec_proxy +#' @export +vec_proxy.rvar = function(x, ...) { + # Using caching to help with algorithms that call vec_proxy + # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 + + out <- attr(x, "cache")$vec_proxy + if (is.null(out)) { + # proxy is not in the cache, calculate it and store it in the cache + out <- make_rvar_proxy(x) + attr(x, "cache")$vec_proxy <- out + } + + out +} + +#' Make a cacheable proxy for vec_proxy.rvar +#' @noRd +make_rvar_proxy = function(x) { + nchains <- nchains(x) + draws <- draws_of(x) + is <- seq_len(NROW(x)) + names(is) <- rownames(x) + lapply(is, function(i) { + list( + index = i, + nchains = nchains, + draws = draws + ) + }) +} + + +#' @importFrom vctrs vec_restore +#' @export +vec_restore.rvar <- function(x, ...) { + if (length(x) == 0) return(rvar()) + + # need to handle the case of creating NAs from NULL entries so that + # vec_init() works properly: vec_init requires vec_slice(x, NA_integer_) + # to give you back NA values, but this breaks because we use lists as proxies. + # When using a list as a proxy, a proxy entry in `x` that is equal to NULL + # actually corresponds to an NA value due to the way that list indexing + # works: when you do something like list()[c(NA_integer_,NA_integer_)] + # you get back list(NULL, NULL), but when you do something like + # double()[c(NA_integer_,NA_integer_)] you get back c(NA, NA). + # So we have to make the NULL values be NA values to mimic vector indexing. + # N.B. could potentially do this with vec_cast as well (as long as the first + # dimension is the slicing index) + x[lengths(x) == 0] <- make_rvar_proxy(new_rvar(NA_real_)) + + # find runs where the same underlying draws are in the proxy + different_draws_from_previous <- vapply(seq_along(x)[-1], FUN.VALUE = logical(1), function(i) { + !identical(x[[i]]$draws, x[[i - 1]]$draws) || !identical(x[[i]]$nchains, x[[i - 1]]$nchains) + }) + draws_groups <- cumsum(c(TRUE, different_draws_from_previous)) + + # convert each run into a slice on an rvar and bind the resulting rvars together + groups <- split(x, draws_groups) + rvars <- lapply(groups, function(x) { + i <- vapply(x, `[[`, "index", FUN.VALUE = numeric(1)) + rvar <- new_rvar(x[[1]]$draws, .nchains = x[[1]]$nchains) + if (length(dim(rvar)) > 1) { + rvar[i, ] + } else { + rvar <- rvar[i] + .dimnames <- dimnames(rvar) + dim(rvar) <- c(length(rvar), 1) + dimnames(rvar) <- c(.dimnames, NULL) + rvar + } + }) + out <- bind_rvars(rvars, arg_exprs = NULL, deparse.level = 0, axis = 1) + + if (all(lengths(lapply(groups, function(x) dim(x[[1]]$draws))) <= 2)) { + # input was a bunch of vectors, ensure output is also a vector + .dimnames <- dimnames(out) + dim(out) <- length(out) + dimnames(out) <- .dimnames[1] + } + + # since we've already spent time calculating it, save the proxy in the cache + # - but only if the proxy only has one group (else we'd have to recalculate + # the bind above again, which is usually more expensive than generating the + # proxy itself) + if (length(groups) == 1) { + attr(out, "cache")$vec_proxy <- x + } + + out +} + +#' @export +vec_restore.rvar_factor = function(x, to, ...) { + x[lengths(x) == 0] <- make_rvar_proxy(rvar_factor(NA_integer_)) + vec_restore.rvar(x, ...) +} + +#' @export +vec_restore.rvar_ordered = function(x, to, ...) { + x[lengths(x) == 0] <- make_rvar_proxy(rvar_ordered(NA_integer_)) + vec_restore.rvar(x, ...) +} + + +# vctrs comparison proxies ------------------------------------------------ + +#' @importFrom vctrs vec_proxy_equal +#' @export +vec_proxy_equal.rvar = function(x, ...) { + # Using caching to help with algorithms that call vec_proxy_equal + # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 + + out <- attr(x, "cache")$vec_proxy_equal + if (is.null(out)) { + # proxy is not in the cache, calculate it and store it in the cache + out <- make_rvar_proxy_equal(x) + attr(x, "cache")$vec_proxy_equal <- out + } + + out +} + +#' Make a cacheable proxy for vec_proxy_equal.rvar +#' @noRd +make_rvar_proxy_equal = function(x) { + lapply(as.list(x), function(x) list( + nchains = nchains(x), + draws = draws_of(x) + )) +} + +#' @importFrom vctrs vec_proxy_compare +#' @export +vec_proxy_compare.rvar = function(x, ...) { + stop_no_call("rvar does not support vctrs::vec_compare()") +} + +#' @importFrom vctrs vec_proxy_order +#' @export +vec_proxy_order.rvar = function(x, ...) { + stop_no_call("rvar does not support vctrs::vec_order()") +} + + +# vec_ptype performance generics ------------------------------------------- + +#' @importFrom vctrs vec_ptype +#' @export +vec_ptype.rvar <- function(x, ..., x_arg = "") new_rvar() +#' @export +vec_ptype.rvar_factor <- function(x, ..., x_arg = "") new_rvar(factor()) +#' @export +vec_ptype.rvar_ordered <- function(x, ..., x_arg = "") new_rvar(ordered(NULL, levels = levels(x))) + + +# identity casts ----------------------------------------------------------- + +#' @importFrom vctrs vec_ptype2 +#' @importFrom vctrs vec_cast +#' @export +vec_ptype2.rvar.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.rvar <- function(x, to, ...) x + +#' @export +vec_ptype2.rvar_factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_factor.rvar_factor <- function(x, to, ...) x + +#' @export +vec_ptype2.rvar_ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_cast.rvar_ordered.rvar_ordered <- function(x, to, ...) x + + +# numeric and logical casts ----------------------------------------------- + +# double -> rvar +#' @export +vec_ptype2.double.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_ptype2.rvar.double <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.double <- function(x, to, ...) new_constant_rvar(x) + +# double -> rvar_factor +#' @export +vec_cast.rvar_factor.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# double -> rvar_ordered +#' @export +vec_cast.rvar_ordered.double <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) + +# integer -> rvar +#' @export +vec_ptype2.integer.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_ptype2.rvar.integer <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.integer <- function(x, to, ...) new_constant_rvar(x) + +# integer -> rvar_factor +#' @export +vec_cast.rvar_factor.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# integer -> rvar_ordered +#' @export +vec_cast.rvar_ordered.integer <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) + +# logical -> rvar +#' @export +vec_ptype2.logical.rvar <- function(x, y, ...) new_rvar() +#' @export +vec_ptype2.rvar.logical <- function(x, y, ...) new_rvar() +#' @export +vec_cast.rvar.logical <- function(x, to, ...) new_constant_rvar(x) + +# logical -> rvar_factor +#' @export +vec_cast.rvar_factor.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# logical -> rvar_ordered +#' @export +vec_cast.rvar_ordered.logical <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.ordered(x))) + + +# character casts --------------------------------------------------------- + +# rvar_[factor|ordered] -> character +#' @export +vec_cast.character.rvar <- function(x, to, ...) format(x) +#' @export +vec_cast.character.rvar_factor <- function(x, to, ...) format(x) +#' @export +vec_cast.character.rvar_ordered <- function(x, to, ...) format(x) + +# character -> rvar +#' @export +vec_cast.rvar.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# character -> rvar_factor +#' @export +vec_ptype2.character.rvar_factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_ptype2.rvar_factor.character <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_factor.character <- function(x, to, ...) new_constant_rvar(copy_dims(x, as.factor(x))) + +# character -> rvar_ordered +#' @export +vec_ptype2.character.rvar_ordered <- function(x, y, ...) rvar_ordered(levels = levels(y)) +#' @export +vec_ptype2.rvar_ordered.character <- function(x, y, ...) rvar_ordered(levels = levels(x)) +#' @export +vec_cast.rvar_ordered.character <- function(x, to, ...) { + old_levels <- levels(to) + new_levels <- sort(setdiff(x, levels(to))) + levels <- c(old_levels, new_levels) + ordered <- length(new_levels) == 0 + new_constant_rvar(copy_dims(x, factor(x, levels = levels, ordered = ordered))) +} + + +# factor casts --------------------------------------------------------- + +# factor -> rvar +#' @export +vec_cast.rvar.factor <- function(x, to, ...) new_constant_rvar(x) + +# factor -> rvar_factor +#' @export +vec_ptype2.factor.rvar_factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_ptype2.rvar_factor.factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_factor.factor <- function(x, to, ...) new_constant_rvar(x) + +# factor -> rvar_ordered +#' @export +vec_ptype2.factor.rvar_ordered <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_ptype2.rvar_ordered.factor <- function(x, y, ...) new_rvar(factor()) +#' @export +vec_cast.rvar_ordered.factor <- function(x, to, ...) new_constant_rvar(x) + +# ordered -> rvar +#' @export +vec_cast.rvar.ordered <- function(x, to, ...) new_constant_rvar(x) + +# ordered -> rvar_factor +#' @export +vec_ptype2.ordered.rvar_factor <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_ptype2.rvar_factor.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_cast.rvar_factor.ordered <- function(x, to, ...) new_constant_rvar(x) + +# ordered -> rvar_ordered +#' @export +vec_ptype2.ordered.rvar_ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_ptype2.rvar_ordered.ordered <- function(x, y, ...) new_rvar(ordered(NULL)) +#' @export +vec_cast.rvar_ordered.ordered <- function(x, to, ...) new_constant_rvar(x) + + +# subtype casts ----------------------------------------------------------- + +#' @export +vec_cast.rvar_factor.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x) +#' @export +vec_cast.rvar_ordered.rvar <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) +#' @export +vec_cast.rvar_factor.rvar_ordered <- function(x, to, ...) .rvar_to_rvar_factor(x) +#' @export +vec_cast.rvar_ordered.rvar_factor <- function(x, to, ...) .rvar_to_rvar_factor(x, ordered = TRUE) +#' @export +vec_cast.rvar.rvar_ordered <- function(x, to, ...) x +#' @export +vec_cast.rvar.rvar_factor <- function(x, to, ...) x + +.rvar_to_rvar_factor <- function(x, ordered = FALSE, ...) { + if ( + ...length() == 0 && + ((ordered && is_rvar_ordered(x)) || (!ordered && is_rvar_factor(x))) + ) { + # already correct type and nothing is being passed to factor() to change it + return(x) + } + + .draws <- draws_of(x) + draws_of(x) <- copy_dims(.draws, factor(.draws, ordered = ordered, ...)) + x +} + + +# casting between rvar and distribution objects --------------------------- + +#' @export +vec_ptype2.distribution.rvar <- function(x, y, ...) x + +#' @export +vec_ptype2.rvar.distribution <- function(x, y, ...) x + +#' @export +vec_cast.rvar.distribution <- function(x, to, ..., x_arg = "", to_arg = "") { + x_list <- vctrs::vec_data(x) + if (length(dim(to)) > 1 || !is_dist_sample_list(x_list)) { + vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) + } + x_rvar_list <- lapply(x_list, function(x) rvar(vctrs::field(x, 1))) + do.call(c, x_rvar_list) +} + +#' @export +vec_cast.distribution.rvar <- function(x, to, ..., x_arg = "", to_arg = "") { + if (length(dim(x)) > 1) { + vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) + } + .draws <- draws_of(x) + x_array_list <- vctrs::vec_chop(aperm(.draws, c(2, 1, seq_along(dim(.draws))[c(-1,-2)]))) + x_vector_list <- lapply(x_array_list, as.vector) + names(x_vector_list) <- names(x) + distributional::dist_sample(x_vector_list) +} + + +# helpers: casting -------------------------------------------------------- + +# create a constant rvar based on x (a double, logical, or integer) +new_constant_rvar <- function(x) { + out <- x + dim_x <- dim(x) + if (length(dim_x) == 0) { + dim(out) <- c(1, length(x)) + } else { + dim(out) <- c(1, dim_x) + dim_i <- seq_along(dim_x) + out <- copy_dimnames(x, dim_i, out, dim_i + 1) + } + new_rvar(out) +} + +# is this a list of dist_sample()s? +is_dist_sample_list <- function(x) { + all(vapply(x, inherits, logical(1), "dist_sample")) +} diff --git a/codecov.yml b/codecov.yml index e5a1ab93..04c55859 100644 --- a/codecov.yml +++ b/codecov.yml @@ -1,14 +1,14 @@ -comment: false - -coverage: - status: - project: - default: - target: auto - threshold: 1% - informational: true - patch: - default: - target: auto - threshold: 1% - informational: true +comment: false + +coverage: + status: + project: + default: + target: auto + threshold: 1% + informational: true + patch: + default: + target: auto + threshold: 1% + informational: true diff --git a/man/as_rvar_factor.Rd b/man/as_rvar_factor.Rd index 6e76871d..df2524cd 100644 --- a/man/as_rvar_factor.Rd +++ b/man/as_rvar_factor.Rd @@ -47,6 +47,9 @@ to override the names of the dimensions of the \code{\link{rvar}} to be created \item{\code{ordered}}{logical flag to determine if the levels should be regarded as ordered (in the order given).} \item{\code{nmax}}{an upper bound on the number of levels; see \sQuote{Details}.} + \item{\code{ifany}}{only add an \code{NA} level if it is used, i.e. + if \code{any(is.na(x))}.} + \item{\code{object}}{an \R object.} }} } \value{ diff --git a/man/draws.Rd b/man/draws.Rd index ec3decd6..7358c430 100755 --- a/man/draws.Rd +++ b/man/draws.Rd @@ -45,11 +45,11 @@ str(y) } \seealso{ -Other formats: -\code{\link{draws_array}()}, -\code{\link{draws_df}()}, -\code{\link{draws_list}()}, -\code{\link{draws_matrix}()}, -\code{\link{draws_rvars}()} +Other formats: +\code{\link[=draws_array]{draws_array()}}, +\code{\link[=draws_df]{draws_df()}}, +\code{\link[=draws_list]{draws_list()}}, +\code{\link[=draws_matrix]{draws_matrix()}}, +\code{\link[=draws_rvars]{draws_rvars()}} } \concept{formats} diff --git a/man/draws_array.Rd b/man/draws_array.Rd index 941cf85e..5f9b2280 100755 --- a/man/draws_array.Rd +++ b/man/draws_array.Rd @@ -73,11 +73,11 @@ print(x2) str(x2) } \seealso{ -Other formats: +Other formats: \code{\link{draws}}, -\code{\link{draws_df}()}, -\code{\link{draws_list}()}, -\code{\link{draws_matrix}()}, -\code{\link{draws_rvars}()} +\code{\link[=draws_df]{draws_df()}}, +\code{\link[=draws_list]{draws_list()}}, +\code{\link[=draws_matrix]{draws_matrix()}}, +\code{\link[=draws_rvars]{draws_rvars()}} } \concept{formats} diff --git a/man/draws_df.Rd b/man/draws_df.Rd index bbfc8206..be9293ed 100755 --- a/man/draws_df.Rd +++ b/man/draws_df.Rd @@ -95,11 +95,11 @@ print(xnew) } \seealso{ -Other formats: +Other formats: \code{\link{draws}}, -\code{\link{draws_array}()}, -\code{\link{draws_list}()}, -\code{\link{draws_matrix}()}, -\code{\link{draws_rvars}()} +\code{\link[=draws_array]{draws_array()}}, +\code{\link[=draws_list]{draws_list()}}, +\code{\link[=draws_matrix]{draws_matrix()}}, +\code{\link[=draws_rvars]{draws_rvars()}} } \concept{formats} diff --git a/man/draws_list.Rd b/man/draws_list.Rd index b696350e..605b9ead 100755 --- a/man/draws_list.Rd +++ b/man/draws_list.Rd @@ -75,11 +75,11 @@ print(x2) str(x2) } \seealso{ -Other formats: +Other formats: \code{\link{draws}}, -\code{\link{draws_array}()}, -\code{\link{draws_df}()}, -\code{\link{draws_matrix}()}, -\code{\link{draws_rvars}()} +\code{\link[=draws_array]{draws_array()}}, +\code{\link[=draws_df]{draws_df()}}, +\code{\link[=draws_matrix]{draws_matrix()}}, +\code{\link[=draws_rvars]{draws_rvars()}} } \concept{formats} diff --git a/man/draws_matrix.Rd b/man/draws_matrix.Rd index 432e3f9b..b7b63117 100755 --- a/man/draws_matrix.Rd +++ b/man/draws_matrix.Rd @@ -73,11 +73,11 @@ print(x2) str(x2) } \seealso{ -Other formats: +Other formats: \code{\link{draws}}, -\code{\link{draws_array}()}, -\code{\link{draws_df}()}, -\code{\link{draws_list}()}, -\code{\link{draws_rvars}()} +\code{\link[=draws_array]{draws_array()}}, +\code{\link[=draws_df]{draws_df()}}, +\code{\link[=draws_list]{draws_list()}}, +\code{\link[=draws_rvars]{draws_rvars()}} } \concept{formats} diff --git a/man/draws_rvars.Rd b/man/draws_rvars.Rd index 28786629..feb9559a 100755 --- a/man/draws_rvars.Rd +++ b/man/draws_rvars.Rd @@ -76,11 +76,11 @@ print(x2) str(x2) } \seealso{ -Other formats: +Other formats: \code{\link{draws}}, -\code{\link{draws_array}()}, -\code{\link{draws_df}()}, -\code{\link{draws_list}()}, -\code{\link{draws_matrix}()} +\code{\link[=draws_array]{draws_array()}}, +\code{\link[=draws_df]{draws_df()}}, +\code{\link[=draws_list]{draws_list()}}, +\code{\link[=draws_matrix]{draws_matrix()}} } \concept{formats} diff --git a/man/ess_basic.Rd b/man/ess_basic.Rd index 8d485bd6..baa6d908 100755 --- a/man/ess_basic.Rd +++ b/man/ess_basic.Rd @@ -71,19 +71,19 @@ Aki Vehtari (2021). Comparison of MCMC effective sample size estimators. Retrieved from https://avehtari.github.io/rhat_ess/ess_comparison.html } \seealso{ -Other diagnostics: -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/ess_bulk.Rd b/man/ess_bulk.Rd index 37206b6d..9a09d2f4 100755 --- a/man/ess_bulk.Rd +++ b/man/ess_bulk.Rd @@ -64,19 +64,19 @@ Aki Vehtari (2021). Comparison of MCMC effective sample size estimators. Retrieved from https://avehtari.github.io/rhat_ess/ess_comparison.html } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/ess_quantile.Rd b/man/ess_quantile.Rd index 075b9ce0..5b456275 100755 --- a/man/ess_quantile.Rd +++ b/man/ess_quantile.Rd @@ -70,19 +70,19 @@ MCMC (with discussion). \emph{Bayesian Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/ess_sd.Rd b/man/ess_sd.Rd index 16015ed8..24179843 100755 --- a/man/ess_sd.Rd +++ b/man/ess_sd.Rd @@ -58,19 +58,19 @@ MCMC (with discussion). \emph{Bayesian Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/ess_tail.Rd b/man/ess_tail.Rd index 9e87d8f1..ddef1b40 100755 --- a/man/ess_tail.Rd +++ b/man/ess_tail.Rd @@ -64,19 +64,19 @@ Aki Vehtari (2021). Comparison of MCMC effective sample size estimators. Retrieved from https://avehtari.github.io/rhat_ess/ess_comparison.html } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/extract_list_of_variable_arrays.Rd b/man/extract_list_of_variable_arrays.Rd index 13273e16..977f339f 100644 --- a/man/extract_list_of_variable_arrays.Rd +++ b/man/extract_list_of_variable_arrays.Rd @@ -53,9 +53,9 @@ str(vars2) } \seealso{ -Other variable extraction methods: -\code{\link{extract_variable}()}, -\code{\link{extract_variable_array}()}, -\code{\link{extract_variable_matrix}()} +Other variable extraction methods: +\code{\link[=extract_variable]{extract_variable()}}, +\code{\link[=extract_variable_array]{extract_variable_array()}}, +\code{\link[=extract_variable_matrix]{extract_variable_matrix()}} } \concept{variable extraction methods} diff --git a/man/extract_variable.Rd b/man/extract_variable.Rd index d8ecf1e5..c375cc1d 100644 --- a/man/extract_variable.Rd +++ b/man/extract_variable.Rd @@ -45,9 +45,9 @@ str(mu) } \seealso{ -Other variable extraction methods: -\code{\link{extract_list_of_variable_arrays}()}, -\code{\link{extract_variable_array}()}, -\code{\link{extract_variable_matrix}()} +Other variable extraction methods: +\code{\link[=extract_list_of_variable_arrays]{extract_list_of_variable_arrays()}}, +\code{\link[=extract_variable_array]{extract_variable_array()}}, +\code{\link[=extract_variable_matrix]{extract_variable_matrix()}} } \concept{variable extraction methods} diff --git a/man/extract_variable_array.Rd b/man/extract_variable_array.Rd index 89fb5859..a8dc6381 100644 --- a/man/extract_variable_array.Rd +++ b/man/extract_variable_array.Rd @@ -54,9 +54,9 @@ str(Sigma) } \seealso{ -Other variable extraction methods: -\code{\link{extract_list_of_variable_arrays}()}, -\code{\link{extract_variable}()}, -\code{\link{extract_variable_matrix}()} +Other variable extraction methods: +\code{\link[=extract_list_of_variable_arrays]{extract_list_of_variable_arrays()}}, +\code{\link[=extract_variable]{extract_variable()}}, +\code{\link[=extract_variable_matrix]{extract_variable_matrix()}} } \concept{variable extraction methods} diff --git a/man/extract_variable_matrix.Rd b/man/extract_variable_matrix.Rd index 7168889b..5c8ec4fd 100644 --- a/man/extract_variable_matrix.Rd +++ b/man/extract_variable_matrix.Rd @@ -47,9 +47,9 @@ rhat(mu) } \seealso{ -Other variable extraction methods: -\code{\link{extract_list_of_variable_arrays}()}, -\code{\link{extract_variable}()}, -\code{\link{extract_variable_array}()} +Other variable extraction methods: +\code{\link[=extract_list_of_variable_arrays]{extract_list_of_variable_arrays()}}, +\code{\link[=extract_variable]{extract_variable()}}, +\code{\link[=extract_variable_array]{extract_variable_array()}} } \concept{variable extraction methods} diff --git a/man/for_each_draw.Rd b/man/for_each_draw.Rd index 531303d8..1655f745 100644 --- a/man/for_each_draw.Rd +++ b/man/for_each_draw.Rd @@ -14,7 +14,7 @@ is defined.} variables in \code{x} by name. This expression will be executed once per draw of \code{x}, where references to variables in \code{x} resolve to the value of that variable in that draw. The expression supports -\link[rlang:topic-inject]{quasiquotation}.} +\link[rlang:quasiquotation]{quasiquotation}.} } \value{ As \code{for_each_draw()} is used primarily for its side effects (the expression diff --git a/man/gpdfit.Rd b/man/gpdfit.Rd index fff04135..6604b4c6 100644 --- a/man/gpdfit.Rd +++ b/man/gpdfit.Rd @@ -50,11 +50,11 @@ Zhang, J., and Stephens, M. A. (2009). A new and efficient estimation method for the generalized Pareto distribution. \emph{Technometrics} \strong{51}, 316-325. } \seealso{ -Other helper-functions: -\code{\link{ps_convergence_rate}()}, -\code{\link{ps_khat_threshold}()}, -\code{\link{ps_min_ss}()}, -\code{\link{ps_tail_length}()} +Other helper-functions: +\code{\link[=ps_convergence_rate]{ps_convergence_rate()}}, +\code{\link[=ps_khat_threshold]{ps_khat_threshold()}}, +\code{\link[=ps_min_ss]{ps_min_ss()}}, +\code{\link[=ps_tail_length]{ps_tail_length()}} } \concept{helper-functions} \keyword{internal} diff --git a/man/mcse_mean.Rd b/man/mcse_mean.Rd index 65828211..abb734c2 100755 --- a/man/mcse_mean.Rd +++ b/man/mcse_mean.Rd @@ -55,19 +55,19 @@ Donald B. Rubin (2013). \emph{Bayesian Data Analysis, Third Edition}. Chapman an Hall/CRC. } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/mcse_quantile.Rd b/man/mcse_quantile.Rd index a7617a0a..d8c45d28 100755 --- a/man/mcse_quantile.Rd +++ b/man/mcse_quantile.Rd @@ -70,19 +70,19 @@ MCMC (with discussion). \emph{Bayesian Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/mcse_sd.Rd b/man/mcse_sd.Rd index 726faeb1..b5614d6e 100755 --- a/man/mcse_sd.Rd +++ b/man/mcse_sd.Rd @@ -60,19 +60,19 @@ doi:10.1214/20-BA1221 J. F. Kenney & E. S. Keeping (1951). \emph{Mathematics of Statistics, Vol. II.} } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/pareto_diags.Rd b/man/pareto_diags.Rd index dcd0194a..244293a3 100644 --- a/man/pareto_diags.Rd +++ b/man/pareto_diags.Rd @@ -143,19 +143,19 @@ Jonah Gabry (2024). Pareto Smoothed Importance Sampling. individual diagnostics; and \code{\link{pareto_smooth}} for Pareto smoothing draws. -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/pareto_khat.Rd b/man/pareto_khat.Rd index c419b1d2..21fdf3a3 100644 --- a/man/pareto_khat.Rd +++ b/man/pareto_khat.Rd @@ -95,19 +95,19 @@ Jonah Gabry (2024). Pareto Smoothed Importance Sampling. \code{\link{pareto_diags}} for additional related diagnostics, and \code{\link{pareto_smooth}} for Pareto smoothed draws. -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/posterior-package.Rd b/man/posterior-package.Rd index 9cd890a6..03c800dc 100644 --- a/man/posterior-package.Rd +++ b/man/posterior-package.Rd @@ -87,6 +87,7 @@ Useful links: Authors: \itemize{ + \item Paul-Christian Bürkner \email{paul.buerkner@gmail.com} \item Jonah Gabry \email{jgabry@gmail.com} \item Matthew Kay \email{mjskay@northwestern.edu} \item Aki Vehtari \email{Aki.Vehtari@aalto.fi} diff --git a/man/print.draws_summary.Rd b/man/print.draws_summary.Rd index 67360901..b73dc48b 100644 --- a/man/print.draws_summary.Rd +++ b/man/print.draws_summary.Rd @@ -9,7 +9,7 @@ \arguments{ \item{x}{(draws_summary) A \code{"draws_summary"} object as output by \code{\link[=summarise_draws]{summarise_draws()}}.} -\item{...}{Additional arguments passed to \code{\link[tibble:formatting]{tibble::print.tbl_df()}}} +\item{...}{Additional arguments passed to \code{\link[tibble:print.tbl_df]{tibble::print.tbl_df()}}} \item{num_args}{(named list) Optional arguments passed to \link[tibble:num]{num()} for pretty printing of summaries. If \code{NULL} diff --git a/man/print.rvar.Rd b/man/print.rvar.Rd index 9e50a230..7709c387 100755 --- a/man/print.rvar.Rd +++ b/man/print.rvar.Rd @@ -52,7 +52,7 @@ first and last category). See \code{\link[=dissent]{dissent()}}. to print. If \code{NULL}, defaults to \code{getOption("posterior.digits", 2)}.} \item{color}{(logical) Whether or not to use color when formatting the -output. If \code{TRUE}, the \code{\link[pillar:style_subtle]{pillar::style_num()}} functions may be used to +output. If \code{TRUE}, the \code{\link[pillar:style_num]{pillar::style_num()}} functions may be used to produce strings containing control sequences to produce colored output on the terminal.} diff --git a/man/ps_convergence_rate.Rd b/man/ps_convergence_rate.Rd index 7f6f4747..a9faea1c 100644 --- a/man/ps_convergence_rate.Rd +++ b/man/ps_convergence_rate.Rd @@ -24,10 +24,10 @@ other packages. For user-facing diagnostic functions, see \code{\link{pareto_convergence_rate}} and \code{\link{pareto_diags}}. } \seealso{ -Other helper-functions: -\code{\link{gpdfit}()}, -\code{\link{ps_khat_threshold}()}, -\code{\link{ps_min_ss}()}, -\code{\link{ps_tail_length}()} +Other helper-functions: +\code{\link[=gpdfit]{gpdfit()}}, +\code{\link[=ps_khat_threshold]{ps_khat_threshold()}}, +\code{\link[=ps_min_ss]{ps_min_ss()}}, +\code{\link[=ps_tail_length]{ps_tail_length()}} } \concept{helper-functions} diff --git a/man/ps_khat_threshold.Rd b/man/ps_khat_threshold.Rd index 75b6c1e2..2e39725b 100644 --- a/man/ps_khat_threshold.Rd +++ b/man/ps_khat_threshold.Rd @@ -23,10 +23,10 @@ user-facing diagnostic functions, see \code{\link{pareto_khat_threshold}} and \code{\link{pareto_diags}}. } \seealso{ -Other helper-functions: -\code{\link{gpdfit}()}, -\code{\link{ps_convergence_rate}()}, -\code{\link{ps_min_ss}()}, -\code{\link{ps_tail_length}()} +Other helper-functions: +\code{\link[=gpdfit]{gpdfit()}}, +\code{\link[=ps_convergence_rate]{ps_convergence_rate()}}, +\code{\link[=ps_min_ss]{ps_min_ss()}}, +\code{\link[=ps_tail_length]{ps_tail_length()}} } \concept{helper-functions} diff --git a/man/ps_min_ss.Rd b/man/ps_min_ss.Rd index 1be3f686..287ef15a 100644 --- a/man/ps_min_ss.Rd +++ b/man/ps_min_ss.Rd @@ -22,10 +22,10 @@ to be usable by other packages. For user-facing diagnostic functions, see \code{\link{pareto_min_ss}} and \code{\link{pareto_diags}}. } \seealso{ -Other helper-functions: -\code{\link{gpdfit}()}, -\code{\link{ps_convergence_rate}()}, -\code{\link{ps_khat_threshold}()}, -\code{\link{ps_tail_length}()} +Other helper-functions: +\code{\link[=gpdfit]{gpdfit()}}, +\code{\link[=ps_convergence_rate]{ps_convergence_rate()}}, +\code{\link[=ps_khat_threshold]{ps_khat_threshold()}}, +\code{\link[=ps_tail_length]{ps_tail_length()}} } \concept{helper-functions} diff --git a/man/ps_tail_length.Rd b/man/ps_tail_length.Rd index 01b734df..9da67523 100644 --- a/man/ps_tail_length.Rd +++ b/man/ps_tail_length.Rd @@ -22,10 +22,10 @@ r_eff. See Appendix H in Vehtari et al. (2024). This function is used internally and is exported to be available for other packages. } \seealso{ -Other helper-functions: -\code{\link{gpdfit}()}, -\code{\link{ps_convergence_rate}()}, -\code{\link{ps_khat_threshold}()}, -\code{\link{ps_min_ss}()} +Other helper-functions: +\code{\link[=gpdfit]{gpdfit()}}, +\code{\link[=ps_convergence_rate]{ps_convergence_rate()}}, +\code{\link[=ps_khat_threshold]{ps_khat_threshold()}}, +\code{\link[=ps_min_ss]{ps_min_ss()}} } \concept{helper-functions} diff --git a/man/rdo.Rd b/man/rdo.Rd index b75ca40c..5caa8ab9 100755 --- a/man/rdo.Rd +++ b/man/rdo.Rd @@ -8,7 +8,7 @@ rdo(expr, dim = NULL, ndraws = NULL) } \arguments{ \item{expr}{(expression) A bare expression that can (optionally) contain -\code{\link{rvar}}s. The expression supports \link[rlang:topic-inject]{quasiquotation}.} +\code{\link{rvar}}s. The expression supports \link[rlang:quasiquotation]{quasiquotation}.} \item{dim}{(integer vector) One or more integers giving the maximal indices in each dimension to override the dimensions of the \code{\link{rvar}} to be created @@ -54,8 +54,8 @@ x } \seealso{ -Other rfun: -\code{\link{rfun}()}, -\code{\link{rvar_rng}()} +Other rfun: +\code{\link[=rfun]{rfun()}}, +\code{\link[=rvar_rng]{rvar_rng()}} } \concept{rfun} diff --git a/man/reexports.Rd b/man/reexports.Rd index 57e4516e..8bbd7a11 100755 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -12,6 +12,6 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \item{distributional}{\code{\link[distributional]{cdf}}, \code{\link[distributional]{variance}}} + \item{distributional}{\code{\link[distributional:cdf]{cdf()}}, \code{\link[distributional:variance]{variance()}}} }} diff --git a/man/rfun.Rd b/man/rfun.Rd index 4d31c031..61444538 100755 --- a/man/rfun.Rd +++ b/man/rfun.Rd @@ -66,8 +66,8 @@ x } \seealso{ -Other rfun: -\code{\link{rdo}()}, -\code{\link{rvar_rng}()} +Other rfun: +\code{\link[=rdo]{rdo()}}, +\code{\link[=rvar_rng]{rvar_rng()}} } \concept{rfun} diff --git a/man/rhat.Rd b/man/rhat.Rd index 6af3b66b..6435be50 100755 --- a/man/rhat.Rd +++ b/man/rhat.Rd @@ -58,19 +58,19 @@ MCMC (with discussion). \emph{Bayesian Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/rhat_basic.Rd b/man/rhat_basic.Rd index 04f47433..23ab9766 100755 --- a/man/rhat_basic.Rd +++ b/man/rhat_basic.Rd @@ -66,19 +66,19 @@ MCMC (with discussion). \emph{Bayesian Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_nested}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_nested]{rhat_nested()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/rhat_nested.Rd b/man/rhat_nested.Rd index 71f51195..31285179 100644 --- a/man/rhat_nested.Rd +++ b/man/rhat_nested.Rd @@ -74,19 +74,19 @@ Assessing the convergence of Markov chain Monte Carlo when running many short chains. \emph{Bayesian Analysis}. doi:10.1214/24-BA1453 } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rstar}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rstar]{rstar()}} } \concept{diagnostics} diff --git a/man/rstar.Rd b/man/rstar.Rd index f2e74898..ef990caf 100644 --- a/man/rstar.Rd +++ b/man/rstar.Rd @@ -106,19 +106,19 @@ diagnostic with uncertainty using gradient-boosted machines. \emph{arXiv preprint} \code{arXiv:2003.07900}. } \seealso{ -Other diagnostics: -\code{\link{ess_basic}()}, -\code{\link{ess_bulk}()}, -\code{\link{ess_quantile}()}, -\code{\link{ess_sd}()}, -\code{\link{ess_tail}()}, -\code{\link{mcse_mean}()}, -\code{\link{mcse_quantile}()}, -\code{\link{mcse_sd}()}, -\code{\link{pareto_diags}()}, -\code{\link{pareto_khat}()}, -\code{\link{rhat}()}, -\code{\link{rhat_basic}()}, -\code{\link{rhat_nested}()} +Other diagnostics: +\code{\link[=ess_basic]{ess_basic()}}, +\code{\link[=ess_bulk]{ess_bulk()}}, +\code{\link[=ess_quantile]{ess_quantile()}}, +\code{\link[=ess_sd]{ess_sd()}}, +\code{\link[=ess_tail]{ess_tail()}}, +\code{\link[=mcse_mean]{mcse_mean()}}, +\code{\link[=mcse_quantile]{mcse_quantile()}}, +\code{\link[=mcse_sd]{mcse_sd()}}, +\code{\link[=pareto_diags]{pareto_diags()}}, +\code{\link[=pareto_khat]{pareto_khat()}}, +\code{\link[=rhat]{rhat()}}, +\code{\link[=rhat_basic]{rhat_basic()}}, +\code{\link[=rhat_nested]{rhat_nested()}} } \concept{diagnostics} diff --git a/man/rvar-summaries-over-draws.Rd b/man/rvar-summaries-over-draws.Rd index 8b7c8caa..d2b64ba1 100755 --- a/man/rvar-summaries-over-draws.Rd +++ b/man/rvar-summaries-over-draws.Rd @@ -154,8 +154,8 @@ pnorm(1.5, mean = 1:4, sd = 2) \link{rvar-summaries-within-draws} for summary functions within draws. \link{rvar-dist} for density, CDF, and quantile functions of random variables. -Other rvar-summaries: +Other rvar-summaries: \code{\link{rvar-summaries-within-draws}}, -\code{\link{rvar_is_finite}()} +\code{\link[=rvar_is_finite]{rvar_is_finite()}} } \concept{rvar-summaries} diff --git a/man/rvar-summaries-within-draws.Rd b/man/rvar-summaries-within-draws.Rd index 90254155..0bb82efd 100755 --- a/man/rvar-summaries-within-draws.Rd +++ b/man/rvar-summaries-within-draws.Rd @@ -95,8 +95,8 @@ rvar_quantile(x, probs = c(0.25, 0.5, 0.75), names = TRUE) \link{rvar-summaries-over-draws} for summary functions across draws (e.g. expectations). \link{rvar-dist} for density, CDF, and quantile functions of random variables. -Other rvar-summaries: +Other rvar-summaries: \code{\link{rvar-summaries-over-draws}}, -\code{\link{rvar_is_finite}()} +\code{\link[=rvar_is_finite]{rvar_is_finite()}} } \concept{rvar-summaries} diff --git a/man/rvar_factor.Rd b/man/rvar_factor.Rd index 92ea056b..52d3deb5 100644 --- a/man/rvar_factor.Rd +++ b/man/rvar_factor.Rd @@ -81,6 +81,9 @@ Ignored when \code{x} is already an \code{\link{rvar}}.} \item{\code{ordered}}{logical flag to determine if the levels should be regarded as ordered (in the order given).} \item{\code{nmax}}{an upper bound on the number of levels; see \sQuote{Details}.} + \item{\code{ifany}}{only add an \code{NA} level if it is used, i.e. + if \code{any(is.na(x))}.} + \item{\code{object}}{an \R object.} }} } \value{ diff --git a/man/rvar_is_finite.Rd b/man/rvar_is_finite.Rd index b1e0ee5f..40187fe1 100755 --- a/man/rvar_is_finite.Rd +++ b/man/rvar_is_finite.Rd @@ -46,7 +46,7 @@ rvar_is_na(x) implementations of \code{is.finite()}, \code{is.infinite()}, \code{is.nan()}, and \code{is.na()} for \code{rvar}s. -Other rvar-summaries: +Other rvar-summaries: \code{\link{rvar-summaries-over-draws}}, \code{\link{rvar-summaries-within-draws}} } diff --git a/man/rvar_rng.Rd b/man/rvar_rng.Rd index 73451055..481c5716 100755 --- a/man/rvar_rng.Rd +++ b/man/rvar_rng.Rd @@ -61,8 +61,8 @@ x } \seealso{ -Other rfun: -\code{\link{rdo}()}, -\code{\link{rfun}()} +Other rfun: +\code{\link[=rdo]{rdo()}}, +\code{\link[=rfun]{rfun()}} } \concept{rfun} From 3f6b50d149ae4d0c64c94c4ea96d551aaf282edf Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 20:41:40 -0700 Subject: [PATCH 3/8] Git blame ignore commit --- .git-blame-ignore-revs | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 .git-blame-ignore-revs diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 00000000..4ec8e33d --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,2 @@ +# normed repo to lf +d3462dbbdf1ed84120a39a9f6ac17311fb798423 From 6dc1d38a429bc995edbee0208b731d21e14c01cf Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 21:28:33 -0700 Subject: [PATCH 4/8] Coerce as needed --- NAMESPACE | 1 + R/rvar-.R | 3 +++ R/rvar-apply.R | 11 ++++++++++- R/rvar-cast.R | 18 ++++++++++++++++++ 4 files changed, 32 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index e40ee84a..5adeef1e 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,6 +42,7 @@ S3method(aperm,rvar) S3method(as.array,rvar) S3method(as.data.frame,rvar) S3method(as.list,rvar) +S3method(as.matrix,rvar) S3method(as.vector,rvar) S3method(as_draws,default) S3method(as_draws,draws) diff --git a/R/rvar-.R b/R/rvar-.R index 667bdb39..c64f5b66 100755 --- a/R/rvar-.R +++ b/R/rvar-.R @@ -201,6 +201,9 @@ new_rvar <- function(x = double(), .nchains = 1L) { #' @export draws_of <- function(x, with_chains = FALSE) { with_chains <- as_one_logical(with_chains) + if (!is_rvar(x) && length(x) && is.list(x) && all(sapply(x, is_rvar))) { + x <- rvar_list_to_rvar(x) + } draws <- attr(x, "draws") if (with_chains) { diff --git a/R/rvar-apply.R b/R/rvar-apply.R index 5767f05e..20af9d95 100755 --- a/R/rvar-apply.R +++ b/R/rvar-apply.R @@ -52,6 +52,15 @@ #' #' @export rvar_apply <- function(.x, .margin, .f, ...) { + .x_orig <- .x + if (is_rvar(.x)) { + .f_orig <- match.fun(.f) + .x <- as.array(.x) + .f <- function(x, ...) { + .f_orig(rvar_list_to_rvar(x), ...) + } + } + # this should return a list of rvars rvar_list <- apply(.x, .margin, .f, ...) if (!is.list(rvar_list) || !all(sapply(rvar_list, is_rvar))) { @@ -90,7 +99,7 @@ rvar_apply <- function(.x, .margin, .f, ...) { } # restore marginal dimnames marginal_dim_i <- seq_along(marginal_dim) - out <- copy_dimnames(.x, .margin, out, marginal_dim_i) + out <- copy_dimnames(.x_orig, .margin, out, marginal_dim_i) } out diff --git a/R/rvar-cast.R b/R/rvar-cast.R index 5236c109..f8f08b1e 100755 --- a/R/rvar-cast.R +++ b/R/rvar-cast.R @@ -175,6 +175,24 @@ as.array.rvar <- function(x, ...) { out } +#' @export +as.matrix.rvar <- as.array.rvar + +#' Collapse a list of rvars from `as.array.rvar()` back into an rvar +#' @noRd +rvar_list_to_rvar <- function(x) { + x_dim <- dim(x) + x_dimnames <- dimnames(x) + x <- do.call(c, unname(as.vector(x))) + if (!is.null(x_dim)) { + dim(x) <- x_dim + if (length(x_dim) > 1) { + dimnames(x) <- x_dimnames + } + } + x +} + #' @importFrom rlang as_label #' @export as.data.frame.rvar <- function(x, ..., optional = FALSE) { From 93af05fe11759528d2770634d2c5f03922be3a7b Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 21:37:50 -0700 Subject: [PATCH 5/8] Fixed test syntax --- tests/testthat/test-rvar-cast.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-rvar-cast.R b/tests/testthat/test-rvar-cast.R index 1ad5a419..c3233c6e 100755 --- a/tests/testthat/test-rvar-cast.R +++ b/tests/testthat/test-rvar-cast.R @@ -264,10 +264,10 @@ test_that("base apply works on multidimensional rvars", { x <- rvar_rng(rnorm, 24, mean = 1:24) dim(x) <- c(2, 3, 4) - expect_equal( - apply(x, c(1, 2), length) |> unname(), - array(4L, dim = c(2, 3)) - ) + expect_equal(unname(apply(x, c(1, 2), length)), array(4L, dim = c(2, 3))) + + dim(x) <- c(6, 4) + expect_equal(unname(apply(x, 1, length)), rep(4L, 6)) }) test_that("as.data.frame and as_tibble work on rvars", { From f39e12f02fb6e584b6c8435ec714167a3963e32d Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 22:07:26 -0700 Subject: [PATCH 6/8] Try to always use binaries for deps --- .github/workflows/rcmdcheck.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/rcmdcheck.yml b/.github/workflows/rcmdcheck.yml index ad010442..9688ecf1 100644 --- a/.github/workflows/rcmdcheck.yml +++ b/.github/workflows/rcmdcheck.yml @@ -43,7 +43,7 @@ jobs: with: r-version: ${{ matrix.config.r }} http-user-agent: ${{ matrix.config.http-user-agent }} - use-public-rspm: true + use-public-rspm: always - uses: r-lib/actions/setup-pandoc@v2 From 59398ee32ba3c852ccb8a8458d11d66f1e6e56cd Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 22:19:23 -0700 Subject: [PATCH 7/8] Install gettext sys libraries for macOS --- .github/workflows/rcmdcheck.yml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/.github/workflows/rcmdcheck.yml b/.github/workflows/rcmdcheck.yml index 9688ecf1..9438f0ff 100644 --- a/.github/workflows/rcmdcheck.yml +++ b/.github/workflows/rcmdcheck.yml @@ -43,7 +43,7 @@ jobs: with: r-version: ${{ matrix.config.r }} http-user-agent: ${{ matrix.config.http-user-agent }} - use-public-rspm: always + use-public-rspm: true - uses: r-lib/actions/setup-pandoc@v2 @@ -75,6 +75,11 @@ jobs: writeLines(rd_lines, rd_file) shell: Rscript {0} + - name: Install macOS R system libraries + if: runner.os == 'macOS' + run: | + sudo Rscript -e 'source("https://mac.R-project.org/bin/install.R"); install.libs("gettext")' + - uses: r-lib/actions/setup-r-dependencies@v2 with: extra-packages: any::rcmdcheck From bc7f533e014152521172219c568b1fd3304bb444 Mon Sep 17 00:00:00 2001 From: VisruthSK Date: Wed, 17 Jun 2026 23:08:37 -0700 Subject: [PATCH 8/8] Guard for casting to matrix --- .Rbuildignore | 1 + R/rvar-cast.R | 7 +++- tests/testthat/test-rvar-cast.R | 64 +++++++++++++++++++++++++++++++-- 3 files changed, 69 insertions(+), 3 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 0c94dacc..d88aeeea 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,4 @@ ^touchstone$ ^codecov\.yml$ ^paper$ +^\.git-blame-ignore-revs$ diff --git a/R/rvar-cast.R b/R/rvar-cast.R index f8f08b1e..0441eb00 100755 --- a/R/rvar-cast.R +++ b/R/rvar-cast.R @@ -176,7 +176,12 @@ as.array.rvar <- function(x, ...) { } #' @export -as.matrix.rvar <- as.array.rvar +as.matrix.rvar <- function(x, ...) { + if (length(dim(x)) != 2) { + stop("Cannot coerce an rvar with ", length(dim(x)), " dimensions to a matrix.") + } + as.array.rvar(x, ...) +} #' Collapse a list of rvars from `as.array.rvar()` back into an rvar #' @noRd diff --git a/tests/testthat/test-rvar-cast.R b/tests/testthat/test-rvar-cast.R index c3233c6e..87941827 100755 --- a/tests/testthat/test-rvar-cast.R +++ b/tests/testthat/test-rvar-cast.R @@ -263,11 +263,71 @@ test_that("base apply works on multidimensional rvars", { set.seed(3456) x <- rvar_rng(rnorm, 24, mean = 1:24) dim(x) <- c(2, 3, 4) + dimnames(x) <- list( + a = paste0("a", 1:2), + b = paste0("b", 1:3), + c = paste0("c", 1:4) + ) + + out <- apply(x, c(1, 2), length) - expect_equal(unname(apply(x, c(1, 2), length)), array(4L, dim = c(2, 3))) + expect_equal(unname(out), array(4L, dim = c(2, 3))) + expect_equal(dimnames(out), dimnames(x)[1:2]) +}) +test_that("base apply works on 2D rvars with dimnames", { + set.seed(3456) + x <- rvar_rng(rnorm, 24, mean = 1:24) dim(x) <- c(6, 4) - expect_equal(unname(apply(x, 1, length)), rep(4L, 6)) + dimnames(x) <- list(row = paste0("r", 1:6), col = paste0("c", 1:4)) + + out <- apply(x, 1, length) + + expect_equal(unname(out), rep(4L, 6)) + expect_equal(names(out), paste0("r", 1:6)) +}) + +test_that("as.array.rvar preserves multidimensional shape and dimnames", { + set.seed(3456) + x <- rvar_rng(rnorm, 24, mean = 1:24) + dim(x) <- c(2, 3, 4) + dimnames(x) <- list( + a = paste0("a", 1:2), + b = paste0("b", 1:3), + c = paste0("c", 1:4) + ) + + out <- as.array(x) + + expect_equal(dim(out), dim(x)) + expect_equal(dimnames(out), dimnames(x)) + expect_true(all(vapply(out, is_rvar, logical(1)))) +}) + +test_that("as.matrix.rvar preserves 2D rvar shape and dimnames", { + set.seed(3456) + x <- rvar_rng(rnorm, 24, mean = 1:24) + dim(x) <- c(6, 4) + dimnames(x) <- list(row = paste0("r", 1:6), col = paste0("c", 1:4)) + + out <- as.matrix(x) + + expect_true(is.matrix(out)) + expect_equal(dim(out), dim(x)) + expect_equal(dimnames(out), dimnames(x)) + expect_true(all(vapply(out, is_rvar, logical(1)))) +}) + +test_that("as.matrix.rvar rejects non-2D rvars", { + set.seed(3456) + x <- rvar_rng(rnorm, 24, mean = 1:24) + dim(x) <- c(2, 3, 4) + + expect_error( + as.matrix(x), + "Cannot coerce an rvar with 3 dimensions to a matrix", + fixed = TRUE + ) }) test_that("as.data.frame and as_tibble work on rvars", {