diff --git a/.Rbuildignore b/.Rbuildignore index 478cd0be..2f3eecbd 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,5 @@ vignettes/loo2-non-factorizable_cache/* ^CRAN-SUBMISSION$ ^release-prep\.R$ +^[\.]?air\.toml$ +^\.vscode$ diff --git a/.github/workflows/format-suggest.yaml b/.github/workflows/format-suggest.yaml new file mode 100644 index 00000000..fca932c7 --- /dev/null +++ b/.github/workflows/format-suggest.yaml @@ -0,0 +1,29 @@ +# Workflow derived from https://github.com/posit-dev/setup-air/tree/main/examples +on: + pull_request: + +name: format-suggest.yaml + +permissions: read-all + +jobs: + format-suggest: + name: format-suggest + runs-on: ubuntu-latest + permissions: + pull-requests: write + steps: + - uses: actions/checkout@v4 + + - name: Install + uses: posit-dev/setup-air@v1 + + - name: Format + run: air format . + + - name: Suggest + uses: reviewdog/action-suggester@v1 + with: + level: error + fail_level: error + tool_name: air diff --git a/R/E_loo.R b/R/E_loo.R index 2fef401a..37e8a1c0 100644 --- a/R/E_loo.R +++ b/R/E_loo.R @@ -100,12 +100,14 @@ E_loo <- function(x, psis_object, ...) { #' @rdname E_loo #' @export E_loo.default <- - function(x, - psis_object, - ..., - type = c("mean", "variance", "sd", "quantile"), - probs = NULL, - log_ratios = NULL) { + function( + x, + psis_object, + ..., + type = c("mean", "variance", "sd", "quantile"), + probs = NULL, + log_ratios = NULL + ) { stopifnot( is.numeric(x), is.psis(psis_object), @@ -137,12 +139,14 @@ E_loo.default <- #' @rdname E_loo #' @export E_loo.matrix <- - function(x, - psis_object, - ..., - type = c("mean", "variance", "sd", "quantile"), - probs = NULL, - log_ratios = NULL) { + function( + x, + psis_object, + ..., + type = c("mean", "variance", "sd", "quantile"), + probs = NULL, + log_ratios = NULL + ) { stopifnot( is.numeric(x), is.psis(psis_object), @@ -162,9 +166,13 @@ E_loo.matrix <- } w <- weights(psis_object, log = FALSE) - out <- vapply(seq_len(ncol(x)), function(i) { - E_fun(x[, i], w[, i], probs = probs) - }, FUN.VALUE = fun_val) + out <- vapply( + seq_len(ncol(x)), + function(i) { + E_fun(x[, i], w[, i], probs = probs) + }, + FUN.VALUE = fun_val + ) if (is.null(log_ratios)) { # Use of smoothed ratios gives slightly optimistic @@ -183,7 +191,6 @@ E_loo.matrix <- } - #' Select the function to use based on user's 'type' argument #' #' @noRd @@ -290,22 +297,37 @@ E_loo_khat.matrix <- function(x, psis_object, log_ratios, ...) { .E_loo_khat_i <- function(x_i, log_ratios_i, tail_len_i) { h_theta <- x_i r_theta <- exp(log_ratios_i - max(log_ratios_i)) - khat_r <- posterior::pareto_khat(r_theta, tail = "right", ndraws_tail = tail_len_i) - if (is.list(khat_r)) { # retain compatiblity with older posterior that returned a list + khat_r <- posterior::pareto_khat( + r_theta, + tail = "right", + ndraws_tail = tail_len_i + ) + if (is.list(khat_r)) { + # retain compatiblity with older posterior that returned a list khat_r <- khat_r$khat } - if (is.null(x_i) || is_constant(x_i) || length(unique(x_i))==2 || - anyNA(x_i) || any(is.infinite(x_i))) { + if ( + is.null(x_i) || + is_constant(x_i) || + length(unique(x_i)) == 2 || + anyNA(x_i) || + any(is.infinite(x_i)) + ) { khat_r } else { - khat_hr <- posterior::pareto_khat(h_theta * r_theta, tail = "both", ndraws_tail = tail_len_i) - if (is.list(khat_hr)) { # retain compatiblity with older posterior that returned a list + khat_hr <- posterior::pareto_khat( + h_theta * r_theta, + tail = "both", + ndraws_tail = tail_len_i + ) + if (is.list(khat_hr)) { + # retain compatiblity with older posterior that returned a list khat_hr <- khat_hr$khat } if (is.na(khat_hr) && is.na(khat_r)) { k <- NA } else { - k <- max(khat_hr, khat_r, na.rm=TRUE) + k <- max(khat_hr, khat_r, na.rm = TRUE) } k } diff --git a/R/compare.R b/R/compare.R index a6081d2f..1d9f619b 100644 --- a/R/compare.R +++ b/R/compare.R @@ -63,8 +63,10 @@ compare <- function(..., x = list()) { dots <- list(...) if (length(dots)) { if (length(x)) { - stop("If 'x' is specified then '...' should not be specified.", - call. = FALSE) + stop( + "If 'x' is specified then '...' should not be specified.", + call. = FALSE + ) } nms <- as.character(match.call(expand.dots = TRUE))[-1L] } else { @@ -97,7 +99,7 @@ compare <- function(..., x = list()) { x <- sapply(dots, function(x) { est <- x$estimates - setNames(c(est), nm = c(rownames(est), paste0("se_", rownames(est))) ) + setNames(c(est), nm = c(rownames(est), paste0("se_", rownames(est)))) }) colnames(x) <- nms rnms <- rownames(x) @@ -105,8 +107,10 @@ compare <- function(..., x = list()) { ord <- order(x[grep("^elpd", rnms), ], decreasing = TRUE) comp <- t(comp)[ord, ] patts <- c("elpd", "p_", "^waic$|^looic$", "^se_waic$|^se_looic$") - col_ord <- unlist(sapply(patts, function(p) grep(p, colnames(comp))), - use.names = FALSE) + col_ord <- unlist( + sapply(patts, function(p) grep(p, colnames(comp))), + use.names = FALSE + ) comp <- comp[, col_ord] # compute elpd_diff and se_elpd_diff relative to best model @@ -122,13 +126,25 @@ compare <- function(..., x = list()) { } - # internal ---------------------------------------------------------------- -compare_two_models <- function(loo_a, loo_b, return = c("elpd_diff", "se"), check_dims = TRUE) { +compare_two_models <- function( + loo_a, + loo_b, + return = c("elpd_diff", "se"), + check_dims = TRUE +) { if (check_dims) { if (dim(loo_a$pointwise)[1] != dim(loo_b$pointwise)[1]) { - stop(paste("Models don't have the same number of data points.", - "\nFound N_1 =", dim(loo_a$pointwise)[1], "and N_2 =", dim(loo_b$pointwise)[1]), call. = FALSE) + stop( + paste( + "Models don't have the same number of data points.", + "\nFound N_1 =", + dim(loo_a$pointwise)[1], + "and N_2 =", + dim(loo_b$pointwise)[1] + ), + call. = FALSE + ) } } diff --git a/R/crps.R b/R/crps.R index ff1c9e25..13895b36 100644 --- a/R/crps.R +++ b/R/crps.R @@ -92,8 +92,7 @@ crps.matrix <- function(x, x2, y, ..., permutations = 1) { #' @rdname crps #' @export crps.numeric <- function(x, x2, y, ..., permutations = 1) { - stopifnot(length(x) == length(x2), - length(y) == 1) + stopifnot(length(x) == length(x2), length(y) == 1) crps.matrix(as.matrix(x), as.matrix(x2), y, permutations) } @@ -106,23 +105,32 @@ crps.numeric <- function(x, x2, y, ..., permutations = 1) { #' @param cores The number of cores to use for parallelization of `[psis()]`. #' See [psis()] for details. loo_crps.matrix <- - function(x, - x2, - y, - log_lik, - ..., - permutations = 1, - r_eff = 1, - cores = getOption("mc.cores", 1)) { - validate_crps_input(x, x2, y, log_lik) - repeats <- replicate(permutations, - EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), - simplify = F) - EXX <- Reduce(`+`, repeats) / permutations - psis_obj <- psis(-log_lik, r_eff = r_eff, cores = cores) - EXy <- E_loo(abs(sweep(x, 2, y)), psis_obj, log_ratios = -log_lik, ...)$value - crps_output(.crps_fun(EXX, EXy)) -} + function( + x, + x2, + y, + log_lik, + ..., + permutations = 1, + r_eff = 1, + cores = getOption("mc.cores", 1) + ) { + validate_crps_input(x, x2, y, log_lik) + repeats <- replicate( + permutations, + EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), + simplify = F + ) + EXX <- Reduce(`+`, repeats) / permutations + psis_obj <- psis(-log_lik, r_eff = r_eff, cores = cores) + EXy <- E_loo( + abs(sweep(x, 2, y)), + psis_obj, + log_ratios = -log_lik, + ... + )$value + crps_output(.crps_fun(EXX, EXy)) + } #' @rdname crps @@ -138,8 +146,7 @@ scrps.matrix <- function(x, x2, y, ..., permutations = 1) { #' @rdname crps #' @export scrps.numeric <- function(x, x2, y, ..., permutations = 1) { - stopifnot(length(x) == length(x2), - length(y) == 1) + stopifnot(length(x) == length(x2), length(y) == 1) scrps.matrix(as.matrix(x), as.matrix(x2), y, permutations) } @@ -155,40 +162,54 @@ loo_scrps.matrix <- ..., permutations = 1, r_eff = 1, - cores = getOption("mc.cores", 1)) { - validate_crps_input(x, x2, y, log_lik) - repeats <- replicate(permutations, - EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), - simplify = F) - EXX <- Reduce(`+`, repeats) / permutations - psis_obj <- psis(-log_lik, r_eff = r_eff, cores = cores) - EXy <- E_loo(abs(sweep(x, 2, y)), psis_obj, log_ratios = -log_lik, ...)$value - crps_output(.crps_fun(EXX, EXy, scale = TRUE)) -} + cores = getOption("mc.cores", 1) + ) { + validate_crps_input(x, x2, y, log_lik) + repeats <- replicate( + permutations, + EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), + simplify = F + ) + EXX <- Reduce(`+`, repeats) / permutations + psis_obj <- psis(-log_lik, r_eff = r_eff, cores = cores) + EXy <- E_loo( + abs(sweep(x, 2, y)), + psis_obj, + log_ratios = -log_lik, + ... + )$value + crps_output(.crps_fun(EXX, EXy, scale = TRUE)) + } # ------------ Internals ---------------- - EXX_compute <- function(x, x2) { S <- nrow(x) - colMeans(abs(x - x2[sample(1:S),])) + colMeans(abs(x - x2[sample(1:S), ])) } EXX_loo_compute <- function(x, x2, log_lik, r_eff = 1, ...) { S <- nrow(x) - shuffle <- sample (1:S) - x2 <- x2[shuffle,] - log_lik2 <- log_lik[shuffle,] - psis_obj_joint <- psis(-log_lik - log_lik2 , r_eff = r_eff) - E_loo(abs(x - x2), psis_obj_joint, log_ratios = -log_lik - log_lik2, ...)$value + shuffle <- sample(1:S) + x2 <- x2[shuffle, ] + log_lik2 <- log_lik[shuffle, ] + psis_obj_joint <- psis(-log_lik - log_lik2, r_eff = r_eff) + E_loo( + abs(x - x2), + psis_obj_joint, + log_ratios = -log_lik - log_lik2, + ... + )$value } #' Function to compute crps and scrps #' @noRd .crps_fun <- function(EXX, EXy, scale = FALSE) { - if (scale) return(-EXy/EXX - 0.5 * log(EXX)) + if (scale) { + return(-EXy / EXX - 0.5 * log(EXX)) + } 0.5 * EXX - EXy } @@ -208,11 +229,12 @@ crps_output <- function(crps_pw) { #' Check that predictive draws and observed data are of compatible shape #' @noRd validate_crps_input <- function(x, x2, y, log_lik = NULL) { - stopifnot(is.numeric(x), - is.numeric(x2), - is.numeric(y), - identical(dim(x), dim(x2)), - ncol(x) == length(y), - ifelse(is.null(log_lik), TRUE, identical(dim(log_lik), dim(x))) - ) + stopifnot( + is.numeric(x), + is.numeric(x2), + is.numeric(y), + identical(dim(x), dim(x2)), + ncol(x) == length(y), + ifelse(is.null(log_lik), TRUE, identical(dim(log_lik), dim(x))) + ) } diff --git a/R/diagnostics.R b/R/diagnostics.R index 77b4eb43..27ca6c83 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -126,7 +126,7 @@ pareto_k_table <- function(x) { S <- dim(x)[1] k_threshold <- ps_khat_threshold(S) kcut <- k_cut(k, k_threshold) - n_eff[k>k_threshold] <- NA + n_eff[k > k_threshold] <- NA min_n_eff <- min_n_eff_by_k(n_eff, kcut) count <- table(kcut) out <- cbind( @@ -144,8 +144,11 @@ print.pareto_k_table <- function(x, digits = 1, ...) { k_threshold <- attr(x, "k_threshold") if (sum(count[2:3]) == 0) { - cat(paste0("\nAll Pareto k estimates are good (k < ", - round(k_threshold,2), ").\n")) + cat(paste0( + "\nAll Pareto k estimates are good (k < ", + round(k_threshold, 2), + ").\n" + )) } else { tab <- cbind( " " = rep("", 3), @@ -201,9 +204,8 @@ pareto_k_values <- function(x) { #' model posterior distribution. pareto_k_influence_values <- function(x) { if ("influence_pareto_k" %in% colnames(x$pointwise)) { - k <- x$pointwise[,"influence_pareto_k"] - } - else { + k <- x$pointwise[, "influence_pareto_k"] + } else { stop("No Pareto k influence estimates found.", call. = FALSE) } return(k) @@ -262,18 +264,22 @@ mcse_loo <- function(x, threshold = NULL) { #' the estimates of the Pareto shape parameters (`diagnostic = "k"`) or #' estimates of the PSIS effective sample sizes (`diagnostic = "ESS"`). #' -plot.psis_loo <- function(x, - diagnostic = c("k", "ESS", "n_eff"), - ..., - label_points = FALSE, - main = "PSIS diagnostic plot") { +plot.psis_loo <- function( + x, + diagnostic = c("k", "ESS", "n_eff"), + ..., + label_points = FALSE, + main = "PSIS diagnostic plot" +) { diagnostic <- match.arg(diagnostic) k <- pareto_k_values(x) - k[is.na(k)] <- 0 # FIXME when reloo is changed to make NA k values -Inf + k[is.na(k)] <- 0 # FIXME when reloo is changed to make NA k values -Inf k_inf <- !is.finite(k) if (any(k_inf)) { - warning(signif(100 * mean(k_inf), 2), - "% of Pareto k estimates are Inf/NA/NaN and not plotted.") + warning( + signif(100 * mean(k_inf), 2), + "% of Pareto k estimates are Inf/NA/NaN and not plotted." + ) } if (diagnostic == "ESS" || diagnostic == "n_eff") { @@ -301,24 +307,34 @@ plot.loo <- plot.psis_loo #' @export #' @rdname pareto-k-diagnostic -plot.psis <- function(x, diagnostic = c("k", "ESS", "n_eff"), ..., - label_points = FALSE, - main = "PSIS diagnostic plot") { - plot.psis_loo(x, diagnostic = diagnostic, ..., - label_points = label_points, main = main) +plot.psis <- function( + x, + diagnostic = c("k", "ESS", "n_eff"), + ..., + label_points = FALSE, + main = "PSIS diagnostic plot" +) { + plot.psis_loo( + x, + diagnostic = diagnostic, + ..., + label_points = label_points, + main = main + ) } - # internal ---------------------------------------------------------------- plot_diagnostic <- - function(k, - n_eff = NULL, - threshold = 0.7, - ..., - label_points = FALSE, - main = "PSIS diagnostic plot") { + function( + k, + n_eff = NULL, + threshold = 0.7, + ..., + label_points = FALSE, + main = "PSIS diagnostic plot" + ) { use_n_eff <- !is.null(n_eff) graphics::plot( x = if (use_n_eff) n_eff else k, @@ -343,13 +359,14 @@ plot_diagnostic <- ltys <- c(3, 2, 1) for (j in seq_along(breaks)) { val <- breaks[j] - if (in_range(val, krange)) + if (in_range(val, krange)) { graphics::abline( h = val, col = ifelse(val == 0, "darkgray", hex_clrs[j - 1]), lty = ltys[j], lwd = 1 ) + } } } @@ -361,13 +378,21 @@ plot_diagnostic <- ifelse(in_range(k, breaks[2:3]), hex_clrs[2], hex_clrs[3]) ) if (all(k < threshold) || !label_points) { - graphics::points(x = if (use_n_eff) n_eff else k, - col = clrs, pch = 3, cex = .6) + graphics::points( + x = if (use_n_eff) n_eff else k, + col = clrs, + pch = 3, + cex = .6 + ) return(invisible()) } else { - graphics::points(x = which(k < threshold), - y = if (use_n_eff) n_eff[k < threshold] else k[k < threshold], - col = clrs[k < threshold], pch = 3, cex = .6) + graphics::points( + x = which(k < threshold), + y = if (use_n_eff) n_eff[k < threshold] else k[k < threshold], + col = clrs[k < threshold], + pch = 3, + cex = .6 + ) sel <- !in_range(k, breaks[1:2]) dots <- list(...) txt_args <- c( @@ -378,9 +403,15 @@ plot_diagnostic <- ), if (length(dots)) dots ) - if (!("adj" %in% names(txt_args))) txt_args$adj <- 2 / 3 - if (!("cex" %in% names(txt_args))) txt_args$cex <- 0.75 - if (!("col" %in% names(txt_args))) txt_args$col <- clrs[sel] + if (!("adj" %in% names(txt_args))) { + txt_args$adj <- 2 / 3 + } + if (!("cex" %in% names(txt_args))) { + txt_args$cex <- 0.75 + } + if (!("col" %in% names(txt_args))) { + txt_args$col <- clrs[sel] + } do.call(graphics::text, txt_args) } @@ -397,9 +428,11 @@ k_cut <- function(k, threshold) { cut( k, breaks = c(-Inf, threshold, 1, Inf), - labels = c(paste0("(-Inf, ", round(threshold,2), "]"), - paste0("(", round(threshold,2), ", 1]"), - "(1, Inf)") + labels = c( + paste0("(-Inf, ", round(threshold, 2), "]"), + paste0("(", round(threshold, 2), ", 1]"), + "(1, Inf)" + ) ) } diff --git a/R/effective_sample_sizes.R b/R/effective_sample_sizes.R index 855bef38..df360447 100644 --- a/R/effective_sample_sizes.R +++ b/R/effective_sample_sizes.R @@ -49,7 +49,12 @@ relative_eff.default <- function(x, chain_id, ...) { #' @templateVar fn relative_eff #' @template matrix #' -relative_eff.matrix <- function(x, chain_id, ..., cores = getOption("mc.cores", 1)) { +relative_eff.matrix <- function( + x, + chain_id, + ..., + cores = getOption("mc.cores", 1) +) { x <- llmatrix_to_array(x, chain_id) relative_eff.array(x, cores = cores) } @@ -70,7 +75,7 @@ relative_eff.array <- function(x, ..., cores = getOption("mc.cores", 1)) { parallel::mclapply( mc.cores = cores, X = seq_len(dim(x)[3]), - FUN = function(i) ess_rfun(x[, , i, drop = TRUE]) + FUN = function(i) ess_rfun(x[,, i, drop = TRUE]) ) } else { cl <- parallel::makePSOCKcluster(cores) @@ -79,7 +84,7 @@ relative_eff.array <- function(x, ..., cores = getOption("mc.cores", 1)) { parallel::parLapply( cl = cl, X = seq_len(dim(x)[3]), - fun = function(i) ess_rfun(x[, , i, drop = TRUE]) + fun = function(i) ess_rfun(x[,, i, drop = TRUE]) ) } n_eff_vec <- unlist(n_eff_list, use.names = FALSE) @@ -94,13 +99,14 @@ relative_eff.array <- function(x, ..., cores = getOption("mc.cores", 1)) { #' @param data,draws,... Same as for the [loo()] function method. #' relative_eff.function <- - function(x, - chain_id, - ..., - cores = getOption("mc.cores", 1), - data = NULL, - draws = NULL) { - + function( + x, + chain_id, + ..., + cores = getOption("mc.cores", 1), + data = NULL, + draws = NULL + ) { f_i <- validate_llfun(x) # not really an llfun, should return exp(ll) or exp(-ll) N <- dim(data)[1] @@ -110,7 +116,11 @@ relative_eff.function <- X = seq_len(N), FUN = function(i) { val_i <- f_i(data_i = data[i, , drop = FALSE], draws = draws, ...) - relative_eff.default(as.vector(val_i), chain_id = chain_id, cores = 1) + relative_eff.default( + as.vector(val_i), + chain_id = chain_id, + cores = 1 + ) } ) } else { @@ -120,13 +130,21 @@ relative_eff.function <- X = seq_len(N), FUN = function(i) { val_i <- f_i(data_i = data[i, , drop = FALSE], draws = draws, ...) - relative_eff.default(as.vector(val_i), chain_id = chain_id, cores = 1) + relative_eff.default( + as.vector(val_i), + chain_id = chain_id, + cores = 1 + ) }, mc.cores = cores ) } else { cl <- parallel::makePSOCKcluster(cores) - parallel::clusterExport(cl=cl, varlist=c("draws", "chain_id", "data"), envir=environment()) + parallel::clusterExport( + cl = cl, + varlist = c("draws", "chain_id", "data"), + envir = environment() + ) on.exit(parallel::stopCluster(cl)) n_eff_list <- parallel::parLapply( @@ -134,7 +152,11 @@ relative_eff.function <- X = seq_len(N), fun = function(i) { val_i <- f_i(data_i = data[i, , drop = FALSE], draws = draws, ...) - relative_eff.default(as.vector(val_i), chain_id = chain_id, cores = 1) + relative_eff.default( + as.vector(val_i), + chain_id = chain_id, + cores = 1 + ) } ) } @@ -155,7 +177,6 @@ relative_eff.importance_sampling <- function(x, ...) { # internal ---------------------------------------------------------------- - #' Effective sample size for PSIS #' #' @noRd @@ -202,16 +223,21 @@ psis_n_eff.matrix <- function(w, r_eff = NULL, ...) { #' @return MCMC effective sample size based on RStan's calculation. #' ess_rfun <- function(sims) { - if (is.vector(sims)) dim(sims) <- c(length(sims), 1) + if (is.vector(sims)) { + dim(sims) <- c(length(sims), 1) + } chains <- ncol(sims) n_samples <- nrow(sims) - acov <- lapply(1:chains, FUN = function(i) posterior::autocovariance(sims[,i])) + acov <- lapply(1:chains, FUN = function(i) { + posterior::autocovariance(sims[, i]) + }) acov <- do.call(cbind, acov) chain_mean <- colMeans(sims) - mean_var <- mean(acov[1,]) * n_samples / (n_samples - 1) + mean_var <- mean(acov[1, ]) * n_samples / (n_samples - 1) var_plus <- mean_var * (n_samples - 1) / n_samples - if (chains > 1) + if (chains > 1) { var_plus <- var_plus + var(chain_mean) + } # Geyer's initial positive sequence rho_hat_t <- rep.int(0, n_samples) t <- 0 @@ -219,8 +245,11 @@ ess_rfun <- function(sims) { rho_hat_t[t + 1] <- rho_hat_even rho_hat_odd <- 1 - (mean_var - mean(acov[t + 2, ])) / var_plus rho_hat_t[t + 2] <- rho_hat_odd - while (t < nrow(acov) - 5 && !is.nan(rho_hat_even + rho_hat_odd) && - (rho_hat_even + rho_hat_odd > 0)) { + while ( + t < nrow(acov) - 5 && + !is.nan(rho_hat_even + rho_hat_odd) && + (rho_hat_even + rho_hat_odd > 0) + ) { t <- t + 2 rho_hat_even = 1 - (mean_var - mean(acov[t + 1, ])) / var_plus rho_hat_odd = 1 - (mean_var - mean(acov[t + 2, ])) / var_plus @@ -231,26 +260,26 @@ ess_rfun <- function(sims) { } max_t <- t # this is used in the improved estimate - if (rho_hat_even>0) - rho_hat_t[max_t + 1] <- rho_hat_even + if (rho_hat_even > 0) { + rho_hat_t[max_t + 1] <- rho_hat_even + } # Geyer's initial monotone sequence t <- 0 while (t <= max_t - 4) { t <- t + 2 - if (rho_hat_t[t + 1] + rho_hat_t[t + 2] > - rho_hat_t[t - 1] + rho_hat_t[t]) { - rho_hat_t[t + 1] = (rho_hat_t[t - 1] + rho_hat_t[t]) / 2; - rho_hat_t[t + 2] = rho_hat_t[t + 1]; + if (rho_hat_t[t + 1] + rho_hat_t[t + 2] > rho_hat_t[t - 1] + rho_hat_t[t]) { + rho_hat_t[t + 1] = (rho_hat_t[t - 1] + rho_hat_t[t]) / 2 + rho_hat_t[t + 2] = rho_hat_t[t + 1] } } ess <- chains * n_samples # Geyer's truncated estimate # tau_hat <- -1 + 2 * sum(rho_hat_t[1:max_t]) # Improved estimate reduces variance in antithetic case - tau_hat <- -1 + 2 * sum(rho_hat_t[1:max_t]) + rho_hat_t[max_t+1] + tau_hat <- -1 + 2 * sum(rho_hat_t[1:max_t]) + rho_hat_t[max_t + 1] # Safety check for negative values and with max ess equal to ess*log10(ess) - tau_hat <- max(tau_hat, 1/log10(ess)) + tau_hat <- max(tau_hat, 1 / log10(ess)) ess <- ess / tau_hat ess } @@ -259,15 +288,23 @@ ess_rfun <- function(sims) { fft_next_good_size <- function(N) { # Find the optimal next size for the FFT so that # a minimum number of zeros are padded. - if (N <= 2) + if (N <= 2) { return(2) + } while (TRUE) { m = N - while ((m %% 2) == 0) m = m / 2 - while ((m %% 3) == 0) m = m / 3 - while ((m %% 5) == 0) m = m / 5 - if (m <= 1) + while ((m %% 2) == 0) { + m = m / 2 + } + while ((m %% 3) == 0) { + m = m / 3 + } + while ((m %% 5) == 0) { + m = m / 5 + } + if (m <= 1) { return(N) + } N = N + 1 } } diff --git a/R/elpd.R b/R/elpd.R index 20724e71..60595e68 100644 --- a/R/elpd.R +++ b/R/elpd.R @@ -45,19 +45,20 @@ elpd.matrix <- function(x, ...) { } - # internal ---------------------------------------------------------------- -pointwise_elpd_calcs <- function(ll){ +pointwise_elpd_calcs <- function(ll) { elpd <- colLogSumExps(ll) - log(nrow(ll)) ic <- -2 * elpd cbind(elpd, ic) } elpd_object <- function(pointwise, dims) { - if (!is.matrix(pointwise)) stop("Internal error ('pointwise' must be a matrix)") + if (!is.matrix(pointwise)) { + stop("Internal error ('pointwise' must be a matrix)") + } cols_to_summarize <- colnames(pointwise) - estimates <- table_of_estimates(pointwise[, cols_to_summarize, drop=FALSE]) + estimates <- table_of_estimates(pointwise[, cols_to_summarize, drop = FALSE]) out <- nlist(estimates, pointwise) structure( out, diff --git a/R/example_log_lik_array.R b/R/example_log_lik_array.R index 914d5d0e..ab968cc1 100644 --- a/R/example_log_lik_array.R +++ b/R/example_log_lik_array.R @@ -35,4 +35,3 @@ example_loglik_matrix <- function() { ll <- example_loglik_array() return(llarray_to_matrix(ll)) } - diff --git a/R/extract_log_lik.R b/R/extract_log_lik.R index 12743b48..50222d61 100644 --- a/R/extract_log_lik.R +++ b/R/extract_log_lik.R @@ -45,15 +45,16 @@ #' #' extract_log_lik <- - function(stanfit, - parameter_name = "log_lik", - merge_chains = TRUE) { - if (!inherits(stanfit, "stanfit")) + function(stanfit, parameter_name = "log_lik", merge_chains = TRUE) { + if (!inherits(stanfit, "stanfit")) { stop("Not a stanfit object.", call. = FALSE) - if (stanfit@mode != 0) + } + if (stanfit@mode != 0) { stop("Stan model does not contain posterior draws.", call. = FALSE) - if (!requireNamespace("rstan", quietly = TRUE)) + } + if (!requireNamespace("rstan", quietly = TRUE)) { stop("Please load the 'rstan' package.", call. = FALSE) + } if (merge_chains) { log_lik <- as.matrix(stanfit, pars = parameter_name) diff --git a/R/gpdfit.R b/R/gpdfit.R index 7bc7c312..3afb6066 100644 --- a/R/gpdfit.R +++ b/R/gpdfit.R @@ -59,9 +59,13 @@ gpdfit <- function(x, wip = TRUE, min_grid_pts = 30, sort_x = TRUE) { # internal ---------------------------------------------------------------- -lx <- function(a,x) { +lx <- function(a, x) { a <- -a - k <- vapply(a, FUN = function(a_i) mean(log1p(a_i * x)), FUN.VALUE = numeric(1)) + k <- vapply( + a, + FUN = function(a_i) mean(log1p(a_i * x)), + FUN.VALUE = numeric(1) + ) log(a / k) - k - 1 } diff --git a/R/helpers.R b/R/helpers.R index 38b401dd..7a16060a 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -92,14 +92,14 @@ llmatrix_to_array <- function(x, chain_id) { chain_counts <- as.numeric(table(chain_id)) if (length(chain_id) != lldim[1]) { - stop("Number of rows in matrix not equal to length(chain_id).", - call. = FALSE) + stop( + "Number of rows in matrix not equal to length(chain_id).", + call. = FALSE + ) } else if (any(chain_counts != chain_counts[1])) { - stop("Not all chains have same number of iterations.", - call. = FALSE) + stop("Not all chains have same number of iterations.", call. = FALSE) } else if (max(chain_id) != n_chain) { - stop("max(chain_id) not equal to the number of chains.", - call. = FALSE) + stop("max(chain_id) not equal to the number of chains.", call. = FALSE) } n_iter <- lldim[1] / n_chain @@ -158,8 +158,9 @@ nlist <- function(...) { out <- list(...) no_names <- is.null(names(out)) has_name <- if (no_names) FALSE else nzchar(names(out)) - if (all(has_name)) + if (all(has_name)) { return(out) + } nms <- as.character(m)[-1L] if (no_names) { names(out) <- nms @@ -176,8 +177,10 @@ loo_cores <- function(cores) { loo_cores_op <- getOption("loo.cores", NA) if (!is.na(loo_cores_op) && (loo_cores_op != cores)) { cores <- loo_cores_op - warning("'loo.cores' is deprecated, please use 'mc.cores' or pass 'cores' explicitly.", - call. = FALSE) + warning( + "'loo.cores' is deprecated, please use 'mc.cores' or pass 'cores' explicitly.", + call. = FALSE + ) } return(cores) } diff --git a/R/importance_sampling.R b/R/importance_sampling.R index 80ec5c8a..4b4557a1 100644 --- a/R/importance_sampling.R +++ b/R/importance_sampling.R @@ -17,32 +17,48 @@ importance_sampling <- function(log_ratios, method, ...) { #' @inheritParams psis #' @export importance_sampling.array <- - function(log_ratios, method, - ..., - r_eff = 1, - cores = getOption("mc.cores", 1)) { + function( + log_ratios, + method, + ..., + r_eff = 1, + cores = getOption("mc.cores", 1) + ) { cores <- loo_cores(cores) stopifnot(length(dim(log_ratios)) == 3) assert_importance_sampling_method_is_implemented(method) log_ratios <- validate_ll(log_ratios) log_ratios <- llarray_to_matrix(log_ratios) r_eff <- prepare_psis_r_eff(r_eff, len = ncol(log_ratios)) - do_importance_sampling(log_ratios, r_eff = r_eff, cores = cores, method = method) + do_importance_sampling( + log_ratios, + r_eff = r_eff, + cores = cores, + method = method + ) } #' @rdname importance_sampling #' @inheritParams psis #' @export importance_sampling.matrix <- - function(log_ratios, method, - ..., - r_eff = 1, - cores = getOption("mc.cores", 1)) { + function( + log_ratios, + method, + ..., + r_eff = 1, + cores = getOption("mc.cores", 1) + ) { cores <- loo_cores(cores) assert_importance_sampling_method_is_implemented(method) log_ratios <- validate_ll(log_ratios) r_eff <- prepare_psis_r_eff(r_eff, len = ncol(log_ratios)) - do_importance_sampling(log_ratios, r_eff = r_eff, cores = cores, method = method) + do_importance_sampling( + log_ratios, + r_eff = r_eff, + cores = cores, + method = method + ) } #' @rdname importance_sampling @@ -54,7 +70,12 @@ importance_sampling.default <- assert_importance_sampling_method_is_implemented(method) dim(log_ratios) <- c(length(log_ratios), 1) r_eff <- prepare_psis_r_eff(r_eff, len = 1) - importance_sampling.matrix(log_ratios, r_eff = r_eff, cores = 1, method = method) + importance_sampling.matrix( + log_ratios, + r_eff = r_eff, + cores = 1, + method = method + ) } @@ -84,16 +105,15 @@ dim.importance_sampling <- function(x) { #' # See the examples at help("psis") #' weights.importance_sampling <- - function(object, - ..., - log = TRUE, - normalize = TRUE) { + function(object, ..., log = TRUE, normalize = TRUE) { out <- object[["log_weights"]] # smoothed but unnormalized log weights if (normalize) { - out <- sweep(out, - MARGIN = 2, - STATS = attr(object, "norm_const_log"), # colLogSumExp(log_weights) - check.margin = FALSE) + out <- sweep( + out, + MARGIN = 2, + STATS = attr(object, "norm_const_log"), # colLogSumExp(log_weights) + check.margin = FALSE + ) } if (!log) { out <- exp(out) @@ -109,13 +129,15 @@ weights.importance_sampling <- #' @keywords internal #' @description #' Currently implemented importance sampling methods -assert_importance_sampling_method_is_implemented <- function(x){ +assert_importance_sampling_method_is_implemented <- function(x) { if (!x %in% implemented_is_methods()) { - stop("Importance sampling method '", - x, - "' is not implemented. Implemented methods: '", - paste0(implemented_is_methods, collapse = "', '"), - "'") + stop( + "Importance sampling method '", + x, + "' is not implemented. Implemented methods: '", + paste0(implemented_is_methods, collapse = "', '"), + "'" + ) } } implemented_is_methods <- function() c("psis", "tis", "sis") @@ -134,11 +156,7 @@ implemented_is_methods <- function() c("psis", "tis", "sis") #' the top of this file. #' importance_sampling_object <- - function(unnormalized_log_weights, - pareto_k, - tail_len, - r_eff, - method) { + function(unnormalized_log_weights, pareto_k, tail_len, r_eff, method) { stopifnot(is.matrix(unnormalized_log_weights)) methods <- unique(method) stopifnot(all(methods %in% implemented_is_methods())) @@ -199,15 +217,17 @@ do_importance_sampling <- function(log_ratios, r_eff, cores, method) { } if (cores == 1) { - lw_list <- lapply(seq_len(N), function(i) - is_fun(log_ratios_i = log_ratios[, i], tail_len_i = tail_len[i])) + lw_list <- lapply(seq_len(N), function(i) { + is_fun(log_ratios_i = log_ratios[, i], tail_len_i = tail_len[i]) + }) } else { if (!os_is_windows()) { lw_list <- parallel::mclapply( X = seq_len(N), mc.cores = cores, - FUN = function(i) + FUN = function(i) { is_fun(log_ratios_i = log_ratios[, i], tail_len_i = tail_len[i]) + } ) } else { cl <- parallel::makePSOCKcluster(cores) @@ -216,8 +236,9 @@ do_importance_sampling <- function(log_ratios, r_eff, cores, method) { parallel::parLapply( cl = cl, X = seq_len(N), - fun = function(i) + fun = function(i) { is_fun(log_ratios_i = log_ratios[, i], tail_len_i = tail_len[i]) + } ) } } diff --git a/R/kfold-helpers.R b/R/kfold-helpers.R index f29b509c..c8274311 100644 --- a/R/kfold-helpers.R +++ b/R/kfold-helpers.R @@ -92,7 +92,7 @@ kfold_split_stratified <- function(K = 10, x = NULL) { } } bins <- rep(NA, N) - bins[xids] <- rep(1:K, ceiling(N/K))[1:N] + bins[xids] <- rep(1:K, ceiling(N / K))[1:N] return(bins) } @@ -117,9 +117,9 @@ kfold_split_grouped <- function(K = 10, x = NULL) { } # Otherwise we have Nlev > K - S1 <- ceiling(Nlev / K) # number of levels in largest groups of levels - N_S2 <- S1 * K - Nlev # number of groups of levels of size S1 - 1 - N_S1 <- K - N_S2 # number of groups of levels of size S1 + S1 <- ceiling(Nlev / K) # number of levels in largest groups of levels + N_S2 <- S1 * K - Nlev # number of groups of levels of size S1 - 1 + N_S1 <- K - N_S2 # number of groups of levels of size S1 perm <- sample.int(Nlev) # permute group levels brks <- seq(from = S1 + 0.5, by = S1, length.out = N_S1) @@ -127,7 +127,7 @@ kfold_split_grouped <- function(K = 10, x = NULL) { brks2 <- seq(from = brks[N_S1] + S1 - 1, by = S1 - 1, length.out = N_S2 - 1) brks <- c(brks, brks2) } - grps <- findInterval(perm, vec = brks) + 1 # +1 so min is 1 not 0 + grps <- findInterval(perm, vec = brks) + 1 # +1 so min is 1 not 0 bins <- rep(NA, length(x)) for (j in perm) { diff --git a/R/loo.R b/R/loo.R index edb9b9b2..06ae922d 100644 --- a/R/loo.R +++ b/R/loo.R @@ -191,14 +191,21 @@ loo <- function(x, ...) { #' @template array #' loo.array <- - function(x, - ..., - r_eff = 1, - save_psis = FALSE, - cores = getOption("mc.cores", 1), - is_method = c("psis", "tis", "sis")) { + function( + x, + ..., + r_eff = 1, + save_psis = FALSE, + cores = getOption("mc.cores", 1), + is_method = c("psis", "tis", "sis") + ) { is_method <- match.arg(is_method) - psis_out <- importance_sampling.array(log_ratios = -x, r_eff = r_eff, cores = cores, method = is_method) + psis_out <- importance_sampling.array( + log_ratios = -x, + r_eff = r_eff, + cores = cores, + method = is_method + ) ll <- llarray_to_matrix(x) pointwise <- pointwise_loo_calcs(ll, psis_out) importance_sampling_loo_object( @@ -215,12 +222,14 @@ loo.array <- #' @template matrix #' loo.matrix <- - function(x, - ..., - r_eff = 1, - save_psis = FALSE, - cores = getOption("mc.cores", 1), - is_method = c("psis", "tis", "sis")) { + function( + x, + ..., + r_eff = 1, + save_psis = FALSE, + cores = getOption("mc.cores", 1), + is_method = c("psis", "tis", "sis") + ) { is_method <- match.arg(is_method) psis_out <- importance_sampling.matrix( @@ -248,14 +257,16 @@ loo.matrix <- #' below for details on how to specify these arguments. #' loo.function <- - function(x, - ..., - data = NULL, - draws = NULL, - r_eff = 1, - save_psis = FALSE, - cores = getOption("mc.cores", 1), - is_method = c("psis", "tis", "sis")) { + function( + x, + ..., + data = NULL, + draws = NULL, + r_eff = 1, + save_psis = FALSE, + cores = getOption("mc.cores", 1), + is_method = c("psis", "tis", "sis") + ) { is_method <- match.arg(is_method) cores <- loo_cores(cores) stopifnot(is.data.frame(data) || is.matrix(data), !is.null(draws)) @@ -321,14 +332,15 @@ loo.function <- #' observation. #' loo_i <- - function(i, - llfun, - ..., - data = NULL, - draws = NULL, - r_eff = 1, - is_method = "psis" - ) { + function( + i, + llfun, + ..., + data = NULL, + draws = NULL, + r_eff = 1, + is_method = "psis" + ) { stopifnot( i == as.integer(i), is.function(llfun) || is.character(llfun), @@ -354,15 +366,16 @@ loo_i <- # for the loo.function method. The arguments and return value are the same as # the ones documented above for the user-facing loo_i function. .loo_i <- - function(i, - llfun, - ..., - data, - draws, - r_eff = 1, - save_psis = FALSE, - is_method) { - + function( + i, + llfun, + ..., + data, + draws, + r_eff = 1, + save_psis = FALSE, + is_method + ) { if (!is.null(r_eff)) { r_eff <- r_eff[i] } @@ -432,7 +445,12 @@ pointwise_loo_calcs <- function(ll, psis_object) { elpd_loo <- matrixStats::colLogSumExps(ll + lw) lpd <- matrixStats::colLogSumExps(ll) - log(nrow(ll)) # colLogMeanExps p_loo <- lpd - elpd_loo - mcse_elpd_loo <- mcse_elpd(ll, lw, E_elpd = elpd_loo, r_eff = relative_eff(psis_object)) + mcse_elpd_loo <- mcse_elpd( + ll, + lw, + E_elpd = elpd_loo, + r_eff = relative_eff(psis_object) + ) looic <- -2 * elpd_loo influence_pareto_k <- psis_object$diagnostics$pareto_k cbind(elpd_loo, mcse_elpd_loo, p_loo, looic, influence_pareto_k) @@ -450,14 +468,24 @@ pointwise_loo_calcs <- function(ll, psis_object) { #' @return A `'importance_sampling_loo'` object as described in the Value section of the [loo()] #' function documentation. #' -importance_sampling_loo_object <- function(pointwise, diagnostics, dims, - is_method, is_object = NULL) { - if (!is.matrix(pointwise)) stop("Internal error ('pointwise' must be a matrix)") - if (!is.list(diagnostics)) stop("Internal error ('diagnostics' must be a list)") +importance_sampling_loo_object <- function( + pointwise, + diagnostics, + dims, + is_method, + is_object = NULL +) { + if (!is.matrix(pointwise)) { + stop("Internal error ('pointwise' must be a matrix)") + } + if (!is.list(diagnostics)) { + stop("Internal error ('diagnostics' must be a list)") + } assert_importance_sampling_method_is_implemented(is_method) - cols_to_summarize <- !(colnames(pointwise) %in% c("mcse_elpd_loo", "influence_pareto_k")) - estimates <- table_of_estimates(pointwise[, cols_to_summarize, drop=FALSE]) + cols_to_summarize <- !(colnames(pointwise) %in% + c("mcse_elpd_loo", "influence_pareto_k")) + estimates <- table_of_estimates(pointwise[, cols_to_summarize, drop = FALSE]) out <- nlist(estimates, pointwise, diagnostics) if (is.null(is_object)) { @@ -467,7 +495,14 @@ importance_sampling_loo_object <- function(pointwise, diagnostics, dims, } # maintain backwards compatibility - old_nms <- c("elpd_loo", "p_loo", "looic", "se_elpd_loo", "se_p_loo", "se_looic") + old_nms <- c( + "elpd_loo", + "p_loo", + "looic", + "se_elpd_loo", + "se_p_loo", + "se_looic" + ) out <- c(out, setNames(as.list(estimates), old_nms)) structure( @@ -501,7 +536,7 @@ mcse_elpd <- function(ll, lw, E_elpd, r_eff, n_samples = NULL) { FUN = function(i) { # Variance in linear scale # Equation (6) in Vehtari et al. (2024) - var_epd_i <- sum(w2[, i] * (lik[, i] - E_epd[i]) ^ 2) / r_eff[i] + var_epd_i <- sum(w2[, i] * (lik[, i] - E_epd[i])^2) / r_eff[i] # Compute variance in log scale by match the variance of a # log-normal approximation # https://en.wikipedia.org/wiki/Log-normal_distribution#Arithmetic_moments @@ -577,16 +612,31 @@ NULL #' @keywords internal #' @export `[.loo` <- function(x, i) { - flags <- c("elpd_loo", "se_elpd_loo", "p_loo", "se_p_loo", "looic", "se_looic", - "elpd_waic", "se_elpd_waic", "p_waic", "se_p_waic", "waic", "se_waic") + flags <- c( + "elpd_loo", + "se_elpd_loo", + "p_loo", + "se_p_loo", + "looic", + "se_looic", + "elpd_waic", + "se_elpd_waic", + "p_waic", + "se_p_waic", + "waic", + "se_waic" + ) if (is.character(i)) { needs_warning <- which(flags == i) if (length(needs_warning)) { warning( - "Accessing ", flags[needs_warning], " using '[' is deprecated ", + "Accessing ", + flags[needs_warning], + " using '[' is deprecated ", "and will be removed in a future release. ", - "Please extract the ", flags[needs_warning], + "Please extract the ", + flags[needs_warning], " estimate from the 'estimates' component instead.", call. = FALSE ) @@ -598,17 +648,32 @@ NULL #' @rdname old-extractors #' @keywords internal #' @export -`[[.loo` <- function(x, i, exact=TRUE) { - flags <- c("elpd_loo", "se_elpd_loo", "p_loo", "se_p_loo", "looic", "se_looic", - "elpd_waic", "se_elpd_waic", "p_waic", "se_p_waic", "waic", "se_waic") +`[[.loo` <- function(x, i, exact = TRUE) { + flags <- c( + "elpd_loo", + "se_elpd_loo", + "p_loo", + "se_p_loo", + "looic", + "se_looic", + "elpd_waic", + "se_elpd_waic", + "p_waic", + "se_p_waic", + "waic", + "se_waic" + ) if (is.character(i)) { needs_warning <- which(flags == i) if (length(needs_warning)) { warning( - "Accessing ", flags[needs_warning], " using '[[' is deprecated ", + "Accessing ", + flags[needs_warning], + " using '[[' is deprecated ", "and will be removed in a future release. ", - "Please extract the ", flags[needs_warning], + "Please extract the ", + flags[needs_warning], " estimate from the 'estimates' component instead.", call. = FALSE ) @@ -622,14 +687,29 @@ NULL #' @export #' `$.loo` <- function(x, name) { - flags <- c("elpd_loo", "se_elpd_loo", "p_loo", "se_p_loo", "looic", "se_looic", - "elpd_waic", "se_elpd_waic", "p_waic", "se_p_waic", "waic", "se_waic") + flags <- c( + "elpd_loo", + "se_elpd_loo", + "p_loo", + "se_p_loo", + "looic", + "se_looic", + "elpd_waic", + "se_elpd_waic", + "p_waic", + "se_p_waic", + "waic", + "se_waic" + ) needs_warning <- which(flags == name) if (length(needs_warning)) { warning( - "Accessing ", flags[needs_warning], " using '$' is deprecated ", + "Accessing ", + flags[needs_warning], + " using '$' is deprecated ", "and will be removed in a future release. ", - "Please extract the ", flags[needs_warning], + "Please extract the ", + flags[needs_warning], " estimate from the 'estimates' component instead.", call. = FALSE ) @@ -650,21 +730,44 @@ NULL #' @param N The total number of observations (i.e. `nrow(data)`). #' @param method See `is_method` for [loo()] #' -parallel_psis_list <- function(N, .loo_i, .llfun, - data, draws, r_eff, - save_psis, cores, - ...){ - parallel_importance_sampling_list(N, .loo_i, .llfun, - data, draws, r_eff, - save_psis, cores, - method = "psis", ...) +parallel_psis_list <- function( + N, + .loo_i, + .llfun, + data, + draws, + r_eff, + save_psis, + cores, + ... +) { + parallel_importance_sampling_list( + N, + .loo_i, + .llfun, + data, + draws, + r_eff, + save_psis, + cores, + method = "psis", + ... + ) } #' @rdname parallel_psis_list -parallel_importance_sampling_list <- function(N, .loo_i, .llfun, - data, draws, r_eff, - save_psis, cores, - method, ...){ +parallel_importance_sampling_list <- function( + N, + .loo_i, + .llfun, + data, + draws, + r_eff, + save_psis, + cores, + method, + ... +) { if (cores == 1) { psis_list <- lapply( diff --git a/R/loo_approximate_posterior.R b/R/loo_approximate_posterior.R index 3a3bce09..bcf9709d 100644 --- a/R/loo_approximate_posterior.R +++ b/R/loo_approximate_posterior.R @@ -41,16 +41,28 @@ loo_approximate_posterior <- function(x, log_p, log_g, ...) { #' @templateVar fn loo_approximate_posterior #' @template array loo_approximate_posterior.array <- - function(x, - log_p, - log_g, - ..., - save_psis = FALSE, - cores = getOption("mc.cores", 1)) { + function( + x, + log_p, + log_g, + ..., + save_psis = FALSE, + cores = getOption("mc.cores", 1) + ) { checkmate::assert_flag(save_psis) checkmate::assert_int(cores) - checkmate::assert_matrix(log_p, mode = "numeric", nrows = dim(x)[1], ncols = dim(x)[2]) - checkmate::assert_matrix(log_g, mode = "numeric", nrows = nrow(log_p), ncols = ncol(log_p)) + checkmate::assert_matrix( + log_p, + mode = "numeric", + nrows = dim(x)[1], + ncols = dim(x)[2] + ) + checkmate::assert_matrix( + log_g, + mode = "numeric", + nrows = nrow(log_p), + ncols = ncol(log_p) + ) ll <- llarray_to_matrix(x) log_p <- as.vector(log_p) @@ -69,12 +81,14 @@ loo_approximate_posterior.array <- #' @templateVar fn loo_approximate_posterior #' @template matrix loo_approximate_posterior.matrix <- - function(x, - log_p, - log_g, - ..., - save_psis = FALSE, - cores = getOption("mc.cores", 1)) { + function( + x, + log_p, + log_g, + ..., + save_psis = FALSE, + cores = getOption("mc.cores", 1) + ) { checkmate::assert_flag(save_psis) checkmate::assert_int(cores) checkmate::assert_numeric(log_p, len = nrow(x)) @@ -106,15 +120,16 @@ loo_approximate_posterior.matrix <- #' details on how to specify these arguments. #' loo_approximate_posterior.function <- - function(x, - ..., - data = NULL, - draws = NULL, - log_p = NULL, - log_g = NULL, - save_psis = FALSE, - cores = getOption("mc.cores", 1)) { - + function( + x, + ..., + data = NULL, + draws = NULL, + log_p = NULL, + log_g = NULL, + save_psis = FALSE, + cores = getOption("mc.cores", 1) + ) { checkmate::assert_numeric(log_p, len = length(log_g)) checkmate::assert_numeric(log_g, len = length(log_p)) cores <- loo_cores(cores) @@ -122,17 +137,19 @@ loo_approximate_posterior.function <- .llfun <- validate_llfun(x) N <- dim(data)[1] - psis_list <- parallel_psis_list(N = N, - .loo_i = .loo_ap_i, - .llfun = .llfun, - data = data, - draws = draws, - r_eff = 1, # r_eff is ignored - save_psis = save_psis, - log_p = log_p, - log_g = log_g, - cores = cores, - ...) + psis_list <- parallel_psis_list( + N = N, + .loo_i = .loo_ap_i, + .llfun = .llfun, + data = data, + draws = draws, + r_eff = 1, # r_eff is ignored + save_psis = save_psis, + log_p = log_p, + log_g = log_g, + cores = cores, + ... + ) pointwise <- lapply(psis_list, "[[", "pointwise") if (save_psis) { @@ -165,24 +182,32 @@ loo_approximate_posterior.function <- # for the loo_approximate_posterior.function method. The arguments and return # value are the same as the ones documented for the user-facing loo_i function. .loo_ap_i <- - function(i, - llfun, - ..., - data, - draws, - log_p, - log_g, - r_eff = 1, - save_psis = FALSE, - is_method) { - - if (is_method != "psis") stop(is_method, " not implemented for aploo.") + function( + i, + llfun, + ..., + data, + draws, + log_p, + log_g, + r_eff = 1, + save_psis = FALSE, + is_method + ) { + if (is_method != "psis") { + stop(is_method, " not implemented for aploo.") + } d_i <- data[i, , drop = FALSE] ll_i <- llfun(data_i = d_i, draws = draws, ...) if (!is.matrix(ll_i)) { ll_i <- as.matrix(ll_i) } - psis_out <- ap_psis(log_ratios = -ll_i, log_p = log_p, log_g = log_g, cores = 1) + psis_out <- ap_psis( + log_ratios = -ll_i, + log_p = log_p, + log_g = log_g, + cores = 1 + ) structure( list( @@ -198,9 +223,28 @@ loo_approximate_posterior.function <- assert_psis_loo_ap <- function(x) { checkmate::assert_class(x, "psis_loo_ap") - checkmate::assert_names(names(x), must.include = c("estimates", "pointwise", "diagnostics", "psis_object", "approximate_posterior")) - checkmate::assert_names(names(x$approximate_posterior), must.include = c("log_p", "log_g")) - checkmate::assert_numeric(x$approximate_posterior$log_p, len = length(x$approximate_posterior$log_g), any.missing = FALSE) - checkmate::assert_numeric(x$approximate_posterior$log_g, len = length(x$approximate_posterior$log_p), any.missing = FALSE) + checkmate::assert_names( + names(x), + must.include = c( + "estimates", + "pointwise", + "diagnostics", + "psis_object", + "approximate_posterior" + ) + ) + checkmate::assert_names( + names(x$approximate_posterior), + must.include = c("log_p", "log_g") + ) + checkmate::assert_numeric( + x$approximate_posterior$log_p, + len = length(x$approximate_posterior$log_g), + any.missing = FALSE + ) + checkmate::assert_numeric( + x$approximate_posterior$log_g, + len = length(x$approximate_posterior$log_p), + any.missing = FALSE + ) } - diff --git a/R/loo_compare.R b/R/loo_compare.R index 028fa59b..81d68ea7 100644 --- a/R/loo_compare.R +++ b/R/loo_compare.R @@ -52,7 +52,7 @@ #' selection process. In that case users are recommended to avoid model #' selection based on LOO-CV, and instead to favor model averaging/stacking or #' projection predictive inference. -#' +#' #' @seealso #' * The [FAQ page](https://mc-stan.org/loo/articles/online-only/faq.html) on #' the __loo__ website for answers to frequently asked questions. @@ -141,14 +141,13 @@ print.compare.loo <- function(x, ..., digits = 1, simplify = TRUE) { xcopy <- xcopy[, grepl(patts, colnames(xcopy))] } } else if (NCOL(xcopy) >= 2 && simplify) { - xcopy <- xcopy[, c("elpd_diff", "se_diff")] + xcopy <- xcopy[, c("elpd_diff", "se_diff")] } print(.fr(xcopy, digits), quote = FALSE) invisible(x) } - # internal ---------------------------------------------------------------- #' Compute pointwise elpd differences @@ -180,40 +179,47 @@ se_elpd_diff <- function(diffs) { loo_compare_checks <- function(loos) { ## errors if (length(loos) <= 1L) { - stop("'loo_compare' requires at least two models.", call.=FALSE) + stop("'loo_compare' requires at least two models.", call. = FALSE) } if (!all(sapply(loos, is.loo))) { - stop("All inputs should have class 'loo'.", call.=FALSE) + stop("All inputs should have class 'loo'.", call. = FALSE) } Ns <- sapply(loos, function(x) nrow(x$pointwise)) if (!all(Ns == Ns[1L])) { - stop("Not all models have the same number of data points.", call.=FALSE) + stop("Not all models have the same number of data points.", call. = FALSE) } ## warnings yhash <- lapply(loos, attr, which = "yhash") - yhash_ok <- sapply(yhash, function(x) { # ok only if all yhash are same (all NULL is ok) + yhash_ok <- sapply(yhash, function(x) { + # ok only if all yhash are same (all NULL is ok) isTRUE(all.equal(x, yhash[[1]])) }) if (!all(yhash_ok)) { - warning("Not all models have the same y variable. ('yhash' attributes do not match)", - call. = FALSE) + warning( + "Not all models have the same y variable. ('yhash' attributes do not match)", + call. = FALSE + ) } if (all(sapply(loos, is.kfold))) { Ks <- unlist(lapply(loos, attr, which = "K")) if (!all(Ks == Ks[1])) { - warning("Not all kfold objects have the same K value. ", - "For a more accurate comparison use the same number of folds. ", - call. = FALSE) + warning( + "Not all kfold objects have the same K value. ", + "For a more accurate comparison use the same number of folds. ", + call. = FALSE + ) } } else if (any(sapply(loos, is.kfold)) && any(sapply(loos, is.psis_loo))) { - warning("Comparing LOO-CV to K-fold-CV. ", - "For a more accurate comparison use the same number of folds ", - "or loo for all models compared.", - call. = FALSE) + warning( + "Comparing LOO-CV to K-fold-CV. ", + "For a more accurate comparison use the same number of folds ", + "or loo for all models compared.", + call. = FALSE + ) } } @@ -253,7 +259,7 @@ find_model_names <- function(x) { #' @keywords internal #' @noRd #' @param loos List of `"loo"` objects. -loo_compare_matrix <- function(loos){ +loo_compare_matrix <- function(loos) { tmp <- sapply(loos, function(x) { est <- x$estimates setNames(c(est), nm = c(rownames(est), paste0("se_", rownames(est)))) @@ -264,8 +270,10 @@ loo_compare_matrix <- function(loos){ ord <- loo_compare_order(loos) comp <- t(comp)[ord, ] patts <- c("elpd", "p_", "^waic$|^looic$", "^se_waic$|^se_looic$") - col_ord <- unlist(sapply(patts, function(p) grep(p, colnames(comp))), - use.names = FALSE) + col_ord <- unlist( + sapply(patts, function(p) grep(p, colnames(comp))), + use.names = FALSE + ) comp <- comp[, col_ord] comp } @@ -274,7 +282,7 @@ loo_compare_matrix <- function(loos){ #' @noRd #' @keywords internal #' @param loos List of `"loo"` objects. -loo_compare_order <- function(loos){ +loo_compare_order <- function(loos) { tmp <- sapply(loos, function(x) { est <- x$estimates setNames(c(est), nm = c(rownames(est), paste0("se_", rownames(est)))) @@ -292,7 +300,6 @@ loo_compare_order <- function(loos){ #' @param ord List of `"loo"` object orderings. #' @return Nothing, just possibly throws errors/warnings. loo_order_stat_check <- function(loos, ord) { - ## breaks if (length(loos) <= 11L) { @@ -321,9 +328,11 @@ loo_order_stat_check <- function(loos, ord) { if (max(elpd_diff) <= order_stat) { # flag warning if we suspect no model is theoretically better than the baseline - warning("Difference in performance potentially due to chance.", - "See McLatchie and Vehtari (2023) for details.", - call. = FALSE) + warning( + "Difference in performance potentially due to chance.", + "See McLatchie and Vehtari (2023) for details.", + call. = FALSE + ) } } diff --git a/R/loo_compare.psis_loo_ss_list.R b/R/loo_compare.psis_loo_ss_list.R index acd0690b..4ec38445 100644 --- a/R/loo_compare.psis_loo_ss_list.R +++ b/R/loo_compare.psis_loo_ss_list.R @@ -6,10 +6,11 @@ #' @author Mans Magnusson #' @export loo_compare.psis_loo_ss_list <- function(x, ...) { - checkmate::assert_list(x, any.missing = FALSE, min.len = 1) - for(i in seq_along(x)){ - if (!inherits(x[[i]], "psis_loo_ss")) x[[i]] <- as.psis_loo_ss.psis_loo(x[[i]]) + for (i in seq_along(x)) { + if (!inherits(x[[i]], "psis_loo_ss")) { + x[[i]] <- as.psis_loo_ss.psis_loo(x[[i]]) + } } loo_compare_checks.psis_loo_ss_list(x) @@ -19,10 +20,17 @@ loo_compare.psis_loo_ss_list <- function(x, ...) { names(x) <- rownames(comp)[ord] rnms <- rownames(comp) - elpd_diff_mat <- matrix(0, nrow = nrow(comp), ncol = 3, - dimnames = list(rnms, c("elpd_diff", "se_diff", "subsampling_se_diff"))) - for(i in 2:length(ord)){ - elpd_diff_mat[i,] <- loo_compare_ss(ref_loo = x[ord[1]], compare_loo = x[ord[i]]) + elpd_diff_mat <- matrix( + 0, + nrow = nrow(comp), + ncol = 3, + dimnames = list(rnms, c("elpd_diff", "se_diff", "subsampling_se_diff")) + ) + for (i in 2:length(ord)) { + elpd_diff_mat[i, ] <- loo_compare_ss( + ref_loo = x[ord[1]], + compare_loo = x[ord[i]] + ) } comp <- cbind(elpd_diff_mat, comp) rownames(comp) <- rnms @@ -36,13 +44,12 @@ loo_compare.psis_loo_ss_list <- function(x, ...) { #' @param ref_loo A named list with a `psis_loo_ss` object. #' @param compare_loo A named list with a `psis_loo_ss` object. #' @return A 1 by 3 elpd_diff estimation. -loo_compare_ss <- function(ref_loo, compare_loo){ +loo_compare_ss <- function(ref_loo, compare_loo) { checkmate::assert_list(ref_loo, names = "named") checkmate::assert_list(compare_loo, names = "named") checkmate::assert_class(ref_loo[[1]], "psis_loo_ss") checkmate::assert_class(compare_loo[[1]], "psis_loo_ss") - ref_idx <- obs_idx(ref_loo[[1]]) compare_idx <- obs_idx(compare_loo[[1]]) intersect_idx <- base::intersect(ref_idx, compare_idx) @@ -50,28 +57,49 @@ loo_compare_ss <- function(ref_loo, compare_loo){ compare_subset_of_ref <- base::setequal(intersect_idx, compare_idx) # Using HH estimation - if (ref_loo[[1]]$loo_subsampling$estimator == "hh_pps" | compare_loo[[1]]$loo_subsampling$estimator == "hh_pps"){ - warning("Hansen-Hurwitz estimator used. Naive diff SE is used.", call. = FALSE) + if ( + ref_loo[[1]]$loo_subsampling$estimator == "hh_pps" | + compare_loo[[1]]$loo_subsampling$estimator == "hh_pps" + ) { + warning( + "Hansen-Hurwitz estimator used. Naive diff SE is used.", + call. = FALSE + ) return(loo_compare_ss_naive(ref_loo, compare_loo)) } # Same observations in both - if (compare_subset_of_ref & ref_subset_of_compare){ + if (compare_subset_of_ref & ref_subset_of_compare) { return(loo_compare_ss_diff(ref_loo, compare_loo)) } # Use subset - if (compare_subset_of_ref | ref_subset_of_compare){ - if (compare_subset_of_ref) ref_loo[[1]] <- update(object = ref_loo[[1]], observations = compare_loo[[1]]) - if (ref_subset_of_compare) compare_loo[[1]] <- update(compare_loo[[1]], observations = ref_loo[[1]]) - message("Estimated elpd_diff using observations included in loo calculations for all models.") + if (compare_subset_of_ref | ref_subset_of_compare) { + if (compare_subset_of_ref) { + ref_loo[[1]] <- update( + object = ref_loo[[1]], + observations = compare_loo[[1]] + ) + } + if (ref_subset_of_compare) { + compare_loo[[1]] <- update(compare_loo[[1]], observations = ref_loo[[1]]) + } + message( + "Estimated elpd_diff using observations included in loo calculations for all models." + ) return(loo_compare_ss_diff(ref_loo, compare_loo)) } # If different samples - if (!compare_subset_of_ref & !ref_subset_of_compare){ - warning("Different subsamples in '", names(ref_loo), "' and '", names(compare_loo), - "'. Naive diff SE is used.", call. = FALSE) + if (!compare_subset_of_ref & !ref_subset_of_compare) { + warning( + "Different subsamples in '", + names(ref_loo), + "' and '", + names(compare_loo), + "'. Naive diff SE is used.", + call. = FALSE + ) return(loo_compare_ss_naive(ref_loo, compare_loo)) } } @@ -80,19 +108,22 @@ loo_compare_ss <- function(ref_loo, compare_loo){ #' @noRd #' @inheritParams loo_compare_ss #' @return a 1 by 3 elpd_diff estimation -loo_compare_ss_naive <- function(ref_loo, compare_loo){ +loo_compare_ss_naive <- function(ref_loo, compare_loo) { checkmate::assert_list(ref_loo, names = "named") checkmate::assert_list(compare_loo, names = "named") checkmate::assert_class(ref_loo[[1]], "psis_loo_ss") checkmate::assert_class(compare_loo[[1]], "psis_loo_ss") - elpd_loo_diff <- ref_loo[[1]]$estimates["elpd_loo","Estimate"] - compare_loo[[1]]$estimates["elpd_loo","Estimate"] + elpd_loo_diff <- ref_loo[[1]]$estimates["elpd_loo", "Estimate"] - + compare_loo[[1]]$estimates["elpd_loo", "Estimate"] elpd_loo_diff_se <- sqrt( - (ref_loo[[1]]$estimates["elpd_loo","SE"])^2 + - (compare_loo[[1]]$estimates["elpd_loo","SE"])^2) + (ref_loo[[1]]$estimates["elpd_loo", "SE"])^2 + + (compare_loo[[1]]$estimates["elpd_loo", "SE"])^2 + ) elpd_loo_diff_subsampling_se <- sqrt( - (ref_loo[[1]]$estimates["elpd_loo","subsampling SE"])^2 + - (compare_loo[[1]]$estimates["elpd_loo","subsampling SE"])^2) + (ref_loo[[1]]$estimates["elpd_loo", "subsampling SE"])^2 + + (compare_loo[[1]]$estimates["elpd_loo", "subsampling SE"])^2 + ) c(elpd_loo_diff, elpd_loo_diff_se, elpd_loo_diff_subsampling_se) } @@ -101,20 +132,33 @@ loo_compare_ss_naive <- function(ref_loo, compare_loo){ #' @noRd #' @inheritParams loo_compare_ss #' @return a 1 by 3 elpd_diff estimation -loo_compare_ss_diff <- function(ref_loo, compare_loo){ +loo_compare_ss_diff <- function(ref_loo, compare_loo) { checkmate::assert_list(ref_loo, names = "named") checkmate::assert_list(compare_loo, names = "named") checkmate::assert_class(ref_loo[[1]], "psis_loo_ss") checkmate::assert_class(compare_loo[[1]], "psis_loo_ss") - checkmate::assert_true(identical(obs_idx(ref_loo[[1]]), obs_idx(compare_loo[[1]]))) + checkmate::assert_true(identical( + obs_idx(ref_loo[[1]]), + obs_idx(compare_loo[[1]]) + )) # Assert not none as loo approximation - checkmate::assert_true(ref_loo[[1]]$loo_subsampling$loo_approximation != "none") - checkmate::assert_true(compare_loo[[1]]$loo_subsampling$loo_approximation != "none") + checkmate::assert_true( + ref_loo[[1]]$loo_subsampling$loo_approximation != "none" + ) + checkmate::assert_true( + compare_loo[[1]]$loo_subsampling$loo_approximation != "none" + ) - diff_approx <- ref_loo[[1]]$loo_subsampling$elpd_loo_approx - compare_loo[[1]]$loo_subsampling$elpd_loo_approx - diff_sample <- ref_loo[[1]]$pointwise[,"elpd_loo"] - compare_loo[[1]]$pointwise[,"elpd_loo"] - est <- srs_diff_est(diff_approx, y = diff_sample, y_idx = ref_loo[[1]]$pointwise[,"idx"]) + diff_approx <- ref_loo[[1]]$loo_subsampling$elpd_loo_approx - + compare_loo[[1]]$loo_subsampling$elpd_loo_approx + diff_sample <- ref_loo[[1]]$pointwise[, "elpd_loo"] - + compare_loo[[1]]$pointwise[, "elpd_loo"] + est <- srs_diff_est( + diff_approx, + y = diff_sample, + y_idx = ref_loo[[1]]$pointwise[, "idx"] + ) elpd_loo_diff <- est$y_hat elpd_loo_diff_se <- sqrt(est$hat_v_y) @@ -134,40 +178,47 @@ loo_compare_ss_diff <- function(ref_loo, compare_loo){ loo_compare_checks.psis_loo_ss_list <- function(loos) { ## errors if (length(loos) <= 1L) { - stop("'loo_compare' requires at least two models.", call.=FALSE) + stop("'loo_compare' requires at least two models.", call. = FALSE) } if (!all(sapply(loos, is.loo))) { - stop("All inputs should have class 'loo'.", call.=FALSE) + stop("All inputs should have class 'loo'.", call. = FALSE) } Ns <- sapply(loos, function(x) x$loo_subsampling$data_dim[1]) if (!all(Ns == Ns[1L])) { - stop("Not all models have the same number of data points.", call.=FALSE) + stop("Not all models have the same number of data points.", call. = FALSE) } ## warnings yhash <- lapply(loos, attr, which = "yhash") - yhash_ok <- sapply(yhash, function(x) { # ok only if all yhash are same (all NULL is ok) + yhash_ok <- sapply(yhash, function(x) { + # ok only if all yhash are same (all NULL is ok) isTRUE(all.equal(x, yhash[[1]])) }) if (!all(yhash_ok)) { - warning("Not all models have the same y variable. ('yhash' attributes do not match)", - call. = FALSE) + warning( + "Not all models have the same y variable. ('yhash' attributes do not match)", + call. = FALSE + ) } if (all(sapply(loos, is.kfold))) { Ks <- unlist(lapply(loos, attr, which = "K")) if (!all(Ks == Ks[1])) { - warning("Not all kfold objects have the same K value. ", - "For a more accurate comparison use the same number of folds. ", - call. = FALSE) + warning( + "Not all kfold objects have the same K value. ", + "For a more accurate comparison use the same number of folds. ", + call. = FALSE + ) } } else if (any(sapply(loos, is.kfold)) && any(sapply(loos, is.psis_loo))) { - warning("Comparing LOO-CV to K-fold-CV. ", - "For a more accurate comparison use the same number of folds ", - "or loo for all models compared.", - call. = FALSE) + warning( + "Comparing LOO-CV to K-fold-CV. ", + "For a more accurate comparison use the same number of folds ", + "or loo for all models compared.", + call. = FALSE + ) } } @@ -193,12 +244,17 @@ print.compare.loo_ss <- function(x, ..., digits = 1, simplify = TRUE) { #' @keywords internal #' @param loos List of `psis_loo_ss` objects. #' @return A `compare.loo_ss` matrix. -loo_compare_matrix.psis_loo_ss_list <- function(loos){ +loo_compare_matrix.psis_loo_ss_list <- function(loos) { tmp <- sapply(loos, function(x) { est <- x$estimates - setNames(c(est), nm = c(rownames(est), - paste0("se_", rownames(est)), - paste0("subsampling_se_", rownames(est)))) + setNames( + c(est), + nm = c( + rownames(est), + paste0("se_", rownames(est)), + paste0("subsampling_se_", rownames(est)) + ) + ) }) colnames(tmp) <- find_model_names(loos) rnms <- rownames(tmp) @@ -206,8 +262,10 @@ loo_compare_matrix.psis_loo_ss_list <- function(loos){ ord <- loo_compare_order(loos) comp <- t(comp)[ord, ] patts <- c("elpd", "p_", "^waic$|^looic$", "se_waic$|se_looic$") - col_ord <- unlist(sapply(patts, function(p) grep(p, colnames(comp))), - use.names = FALSE) + col_ord <- unlist( + sapply(patts, function(p) grep(p, colnames(comp))), + use.names = FALSE + ) comp <- comp[, col_ord] comp } diff --git a/R/loo_model_weights.R b/R/loo_model_weights.R index 449e8feb..9f4d655d 100644 --- a/R/loo_model_weights.R +++ b/R/loo_model_weights.R @@ -169,17 +169,18 @@ loo_model_weights <- function(x, ...) { #' @export #' @export loo_model_weights.default loo_model_weights.default <- - function(x, - ..., - method = c("stacking", "pseudobma"), - optim_method = "BFGS", - optim_control = list(), - BB = TRUE, - BB_n = 1000, - alpha = 1, - r_eff_list = NULL, - cores = getOption("mc.cores", 1)) { - + function( + x, + ..., + method = c("stacking", "pseudobma"), + optim_method = "BFGS", + optim_control = list(), + BB = TRUE, + BB_n = 1000, + alpha = 1, + r_eff_list = NULL, + cores = getOption("mc.cores", 1) + ) { cores <- loo_cores(cores) method <- match.arg(method) K <- length(x) # number of models @@ -194,25 +195,27 @@ loo_model_weights.default <- r_eff_k <- r_eff_list[[k]] # possibly NULL log_likelihood <- x[[k]] loo_object <- loo(log_likelihood, r_eff = r_eff_k, cores = cores) - lpd_point[, k] <- loo_object$pointwise[, "elpd_loo"] #calculate log(p_k (y_i | y_-i)) + lpd_point[, k] <- loo_object$pointwise[, "elpd_loo"] #calculate log(p_k (y_i | y_-i)) elpd_loo[k] <- loo_object$estimates["elpd_loo", "Estimate"] } } else if (is.psis_loo(x[[1]])) { validate_psis_loo_list(x) - lpd_point <- do.call(cbind, lapply(x, function(obj) obj$pointwise[, "elpd_loo"])) + lpd_point <- do.call( + cbind, + lapply(x, function(obj) obj$pointwise[, "elpd_loo"]) + ) elpd_loo <- sapply(x, function(obj) obj$estimates["elpd_loo", "Estimate"]) } else { stop("'x' must be a list of matrices or a list of 'psis_loo' objects.") } ## 1) stacking on log score - if (method =="stacking") { + if (method == "stacking") { wts <- stacking_weights( lpd_point = lpd_point, optim_method = optim_method, optim_control = optim_control ) - } else { # method =="pseudobma" wts <- pseudobma_weights( @@ -227,7 +230,8 @@ loo_model_weights.default <- if (!is.null(names(x)) && all(nzchar(names(x)))) { wts <- setNames(wts, names(x)) } - } else { # list of loo objects + } else { + # list of loo objects wts <- setNames(wts, find_model_names(x)) } wts @@ -247,10 +251,7 @@ loo_model_weights.default <- #' @importFrom stats constrOptim #' stacking_weights <- - function(lpd_point, - optim_method = "BFGS", - optim_control = list()) { - + function(lpd_point, optim_method = "BFGS", optim_control = list()) { stopifnot(is.matrix(lpd_point)) N <- nrow(lpd_point) K <- ncol(lpd_point) @@ -263,7 +264,12 @@ stacking_weights <- stopifnot(length(w) == K - 1) w_full <- c(w, 1 - sum(w)) # avoid over- and underflows using log weights and rowLogSumExps - sum <- sum(matrixStats::rowLogSumExps(sweep(lpd_point[1:N,], 2, log(w_full), '+'))) + sum <- sum(matrixStats::rowLogSumExps(sweep( + lpd_point[1:N, ], + 2, + log(w_full), + '+' + ))) return(-as.numeric(sum)) } @@ -276,12 +282,23 @@ stacking_weights <- # and by subtracting the row maximum of lpd_point mlpd <- matrixStats::rowMaxs(lpd_point) for (k in 1:(K - 1)) { - grad[k] <- sum((exp(lpd_point[, k] - mlpd) - exp(lpd_point[, K] - mlpd)) / exp(matrixStats::rowLogSumExps(sweep(lpd_point, 2, log(w_full), '+')) - mlpd)) + grad[k] <- sum( + (exp(lpd_point[, k] - mlpd) - exp(lpd_point[, K] - mlpd)) / + exp( + matrixStats::rowLogSumExps(sweep( + lpd_point, + 2, + log(w_full), + '+' + )) - + mlpd + ) + ) } return(-grad) } - ui <- rbind(rep(-1, K - 1), diag(K - 1)) # K-1 simplex constraint matrix + ui <- rbind(rep(-1, K - 1), diag(K - 1)) # K-1 simplex constraint matrix ci <- c(-1, rep(0, K - 1)) w <- constrOptim( theta = rep(1 / K, K - 1), @@ -307,10 +324,7 @@ stacking_weights <- #' @export #' pseudobma_weights <- - function(lpd_point, - BB = TRUE, - BB_n = 1000, - alpha = 1) { + function(lpd_point, BB = TRUE, BB_n = 1000, alpha = 1) { stopifnot(is.matrix(lpd_point)) N <- nrow(lpd_point) K <- ncol(lpd_point) @@ -388,17 +402,23 @@ print_weight_vector <- function(x, digits) { #' @return Either throws an error or returns `TRUE` invisibly. #' validate_r_eff_list <- function(r_eff_list, K, N) { - if (is.null(r_eff_list)) return(invisible(TRUE)) + if (is.null(r_eff_list)) { + return(invisible(TRUE)) + } if (length(r_eff_list) != K) { - stop("If r_eff_list is specified then it must contain ", - "one component for each model being compared.", - call. = FALSE) + stop( + "If r_eff_list is specified then it must contain ", + "one component for each model being compared.", + call. = FALSE + ) } if (any(sapply(r_eff_list, length) != N)) { - stop("Each component of r_eff list must have the same length ", - "as the number of columns in the log-likelihood matrix.", - call. = FALSE) + stop( + "Each component of r_eff list must have the same length ", + "as the number of columns in the log-likelihood matrix.", + call. = FALSE + ) } invisible(TRUE) } @@ -419,9 +439,14 @@ validate_log_lik_list <- function(log_lik_list) { if (length(log_lik_list) < 2) { stop("At least two models are required.", call. = FALSE) } - if (length(unique(sapply(log_lik_list, ncol))) != 1 | - length(unique(sapply(log_lik_list, nrow))) != 1) { - stop("Each log-likelihood matrix must have the same dimensions.", call. = FALSE) + if ( + length(unique(sapply(log_lik_list, ncol))) != 1 | + length(unique(sapply(log_lik_list, nrow))) != 1 + ) { + stop( + "Each log-likelihood matrix must have the same dimensions.", + call. = FALSE + ) } invisible(TRUE) } @@ -432,13 +457,20 @@ validate_psis_loo_list <- function(psis_loo_list) { stop("At least two models are required.", call. = FALSE) } if (!all(sapply(psis_loo_list, is.psis_loo))) { - stop("List elements must all be 'psis_loo' objects or log-likelihood matrices.") + stop( + "List elements must all be 'psis_loo' objects or log-likelihood matrices." + ) } dims <- sapply(psis_loo_list, dim) - if (length(unique(dims[1, ])) != 1 | - length(unique(dims[2, ])) != 1) { - stop("Each object in the list must have the same dimensions.", call. = FALSE) + if ( + length(unique(dims[1, ])) != 1 | + length(unique(dims[2, ])) != 1 + ) { + stop( + "Each object in the list must have the same dimensions.", + call. = FALSE + ) } invisible(TRUE) } diff --git a/R/loo_moment_matching.R b/R/loo_moment_matching.R index 110eff93..41c63f42 100644 --- a/R/loo_moment_matching.R +++ b/R/loo_moment_matching.R @@ -63,34 +63,42 @@ loo_moment_match <- function(x, ...) { #' functions `post_draws`, `log_lik_i`, `unconstrain_pars`, `log_prob_upars`, #' and `log_lik_i_upars`. #' @export -loo_moment_match.default <- function(x, loo, post_draws, log_lik_i, - unconstrain_pars, log_prob_upars, - log_lik_i_upars, max_iters = 30L, - k_threshold = NULL, split = TRUE, - cov = TRUE, cores = getOption("mc.cores", 1), - ...) { - +loo_moment_match.default <- function( + x, + loo, + post_draws, + log_lik_i, + unconstrain_pars, + log_prob_upars, + log_lik_i_upars, + max_iters = 30L, + k_threshold = NULL, + split = TRUE, + cov = TRUE, + cores = getOption("mc.cores", 1), + ... +) { # input checks - checkmate::assertClass(loo,classes = "loo") + checkmate::assertClass(loo, classes = "loo") checkmate::assertFunction(post_draws) checkmate::assertFunction(log_lik_i) checkmate::assertFunction(unconstrain_pars) checkmate::assertFunction(log_prob_upars) checkmate::assertFunction(log_lik_i_upars) checkmate::assertNumber(max_iters) - checkmate::assertNumber(k_threshold, null.ok=TRUE) + checkmate::assertNumber(k_threshold, null.ok = TRUE) checkmate::assertLogical(split) checkmate::assertLogical(cov) checkmate::assertNumber(cores) - if ("psis_loo" %in% class(loo)) { is_method <- "psis" } else { - stop("loo_moment_match currently supports only the \"psis\" importance sampling class.") + stop( + "loo_moment_match currently supports only the \"psis\" importance sampling class." + ) } - S <- dim(loo)[1] N <- dim(loo)[2] if (is.null(k_threshold)) { @@ -108,33 +116,45 @@ loo_moment_match.default <- function(x, loo, post_draws, log_lik_i, # loop over all observations whose Pareto k is high ks <- loo$diagnostics$pareto_k - kfs <- rep(0,N) + kfs <- rep(0, N) I <- which(ks > k_threshold) loo_moment_match_i_fun <- function(i) { - loo_moment_match_i(i = i, x = x, log_lik_i = log_lik_i, - unconstrain_pars = unconstrain_pars, - log_prob_upars = log_prob_upars, - log_lik_i_upars = log_lik_i_upars, - max_iters = max_iters, k_threshold = k_threshold, - split = split, cov = cov, N = N, S = S, upars = upars, - orig_log_prob = orig_log_prob, k = ks[i], - is_method = is_method, npars = npars, ...) + loo_moment_match_i( + i = i, + x = x, + log_lik_i = log_lik_i, + unconstrain_pars = unconstrain_pars, + log_prob_upars = log_prob_upars, + log_lik_i_upars = log_lik_i_upars, + max_iters = max_iters, + k_threshold = k_threshold, + split = split, + cov = cov, + N = N, + S = S, + upars = upars, + orig_log_prob = orig_log_prob, + k = ks[i], + is_method = is_method, + npars = npars, + ... + ) } if (cores == 1) { mm_list <- lapply(X = I, FUN = function(i) loo_moment_match_i_fun(i)) - } - else { + } else { if (!os_is_windows()) { - mm_list <- parallel::mclapply(X = I, mc.cores = cores, - FUN = function(i) loo_moment_match_i_fun(i)) - } - else { + mm_list <- parallel::mclapply(X = I, mc.cores = cores, FUN = function(i) { + loo_moment_match_i_fun(i) + }) + } else { cl <- parallel::makePSOCKcluster(cores) on.exit(parallel::stopCluster(cl)) - mm_list <- parallel::parLapply(cl = cl, X = I, - fun = function(i) loo_moment_match_i_fun(i)) + mm_list <- parallel::parLapply(cl = cl, X = I, fun = function(i) { + loo_moment_match_i_fun(i) + }) } } @@ -155,23 +175,27 @@ loo_moment_match.default <- function(x, loo, post_draws, log_lik_i, } } if (!is.null(loo$psis_object)) { - attr(loo$psis_object, "norm_const_log") <- matrixStats::colLogSumExps(loo$psis_object$log_weights) + attr(loo$psis_object, "norm_const_log") <- matrixStats::colLogSumExps( + loo$psis_object$log_weights + ) loo$psis_object$diagnostics <- loo$diagnostics } # combined estimates - cols_to_summarize <- !(colnames(loo$pointwise) %in% c("mcse_elpd_loo", - "influence_pareto_k")) - loo$estimates <- table_of_estimates(loo$pointwise[, cols_to_summarize, - drop = FALSE]) + cols_to_summarize <- !(colnames(loo$pointwise) %in% + c("mcse_elpd_loo", "influence_pareto_k")) + loo$estimates <- table_of_estimates(loo$pointwise[, + cols_to_summarize, + drop = FALSE + ]) # these will be deprecated at some point - loo$elpd_loo <- loo$estimates["elpd_loo","Estimate"] - loo$p_loo <- loo$estimates["p_loo","Estimate"] - loo$looic <- loo$estimates["looic","Estimate"] - loo$se_elpd_loo <- loo$estimates["elpd_loo","SE"] - loo$se_p_loo <- loo$estimates["p_loo","SE"] - loo$se_looic <- loo$estimates["looic","SE"] + loo$elpd_loo <- loo$estimates["elpd_loo", "Estimate"] + loo$p_loo <- loo$estimates["p_loo", "Estimate"] + loo$looic <- loo$estimates["looic", "Estimate"] + loo$se_elpd_loo <- loo$estimates["elpd_loo", "SE"] + loo$se_p_loo <- loo$estimates["p_loo", "SE"] + loo$se_looic <- loo$estimates["looic", "SE"] # Warn if some Pareto ks are still high throw_pareto_warnings(loo$diagnostics$pareto_k, k_threshold) @@ -184,11 +208,8 @@ loo_moment_match.default <- function(x, loo, post_draws, log_lik_i, } - - # Internal functions --------------- - #' Do moment matching for a single observation. #' #' @noRd @@ -230,24 +251,26 @@ loo_moment_match.default <- function(x, loo, post_draws, log_lik_i, #' @param ... Further arguments passed to the custom functions documented above. #' @return List with the updated elpd values and diagnostics #' -loo_moment_match_i <- function(i, - x, - log_lik_i, - unconstrain_pars, - log_prob_upars, - log_lik_i_upars, - max_iters, - k_threshold, - split, - cov, - N, - S, - upars, - orig_log_prob, - k, - is_method, - npars, - ...) { +loo_moment_match_i <- function( + i, + x, + log_lik_i, + unconstrain_pars, + log_prob_upars, + log_lik_i_upars, + max_iters, + k_threshold, + split, + cov, + N, + S, + upars, + orig_log_prob, + k, + is_method, + npars, + ... +) { # initialize values for this LOO-fold uparsi <- upars ki <- k @@ -260,12 +283,14 @@ loo_moment_match_i <- function(i, dim(log_liki) <- NULL lpd <- matrixStats::logSumExp(log_liki) - log(length(log_liki)) - is_obj <- suppressWarnings(importance_sampling.default(-log_liki, - method = is_method, - r_eff = r_eff_i, - cores = 1)) + is_obj <- suppressWarnings(importance_sampling.default( + -log_liki, + method = is_method, + r_eff = r_eff_i, + cores = 1 + )) lwi <- as.vector(weights(is_obj)) - lwfi <- rep(-matrixStats::logSumExp(rep(0, S)),S) + lwfi <- rep(-matrixStats::logSumExp(rep(0, S)), S) # initialize objects that keep track of the total transformation total_shift <- rep(0, npars) @@ -278,7 +303,6 @@ loo_moment_match_i <- function(i, # when transformation succeeds, start again from the first one iterind <- 1 while (iterind <= max_iters && ki > k_threshold) { - if (iterind == max_iters) { throw_moment_match_max_iters_warning() } @@ -286,15 +310,18 @@ loo_moment_match_i <- function(i, # 1. match means trans <- shift(x, uparsi, lwi) # gather updated quantities - quantities_i <- try(update_quantities_i(x, trans$upars, i = i, - orig_log_prob = orig_log_prob, - log_prob_upars = log_prob_upars, - log_lik_i_upars = log_lik_i_upars, - r_eff_i = r_eff_i, - cores = 1, - is_method = is_method, - ...) - ) + quantities_i <- try(update_quantities_i( + x, + trans$upars, + i = i, + orig_log_prob = orig_log_prob, + log_prob_upars = log_prob_upars, + log_lik_i_upars = log_lik_i_upars, + r_eff_i = r_eff_i, + cores = 1, + is_method = is_method, + ... + )) if (inherits(quantities_i, "try-error")) { # Stan log prob caused an exception probably due to under- or # overflow of parameters to invalid values @@ -316,15 +343,18 @@ loo_moment_match_i <- function(i, # 2. match means and marginal variances trans <- shift_and_scale(x, uparsi, lwi) # gather updated quantities - quantities_i <- try(update_quantities_i(x, trans$upars, i = i, - orig_log_prob = orig_log_prob, - log_prob_upars = log_prob_upars, - log_lik_i_upars = log_lik_i_upars, - r_eff_i = r_eff_i, - cores = 1, - is_method = is_method, - ...) - ) + quantities_i <- try(update_quantities_i( + x, + trans$upars, + i = i, + orig_log_prob = orig_log_prob, + log_prob_upars = log_prob_upars, + log_lik_i_upars = log_lik_i_upars, + r_eff_i = r_eff_i, + cores = 1, + is_method = is_method, + ... + )) if (inherits(quantities_i, "try-error")) { # Stan log prob caused an exception probably due to under- or # overflow of parameters to invalid values @@ -348,15 +378,18 @@ loo_moment_match_i <- function(i, if (cov) { trans <- shift_and_cov(x, uparsi, lwi) # gather updated quantities - quantities_i <- try(update_quantities_i(x, trans$upars, i = i, - orig_log_prob = orig_log_prob, - log_prob_upars = log_prob_upars, - log_lik_i_upars = log_lik_i_upars, - r_eff_i = r_eff_i, - cores = 1, - is_method = is_method, - ...) - ) + quantities_i <- try(update_quantities_i( + x, + trans$upars, + i = i, + orig_log_prob = orig_log_prob, + log_prob_upars = log_prob_upars, + log_lik_i_upars = log_lik_i_upars, + r_eff_i = r_eff_i, + cores = 1, + is_method = is_method, + ... + )) if (inherits(quantities_i, "try-error")) { # Stan log prob caused an exception probably due to under- or @@ -389,16 +422,25 @@ loo_moment_match_i <- function(i, if (split && (iterind > 1)) { # compute split transformation split_obj <- loo_moment_match_split( - x, upars, cov, total_shift, total_scaling, total_mapping, i, - log_prob_upars = log_prob_upars, log_lik_i_upars = log_lik_i_upars, - cores = 1, r_eff_i = r_eff_i, is_method = is_method, ... + x, + upars, + cov, + total_shift, + total_scaling, + total_mapping, + i, + log_prob_upars = log_prob_upars, + log_lik_i_upars = log_lik_i_upars, + cores = 1, + r_eff_i = r_eff_i, + is_method = is_method, + ... ) log_liki <- split_obj$log_liki lwi <- split_obj$lwi lwfi <- split_obj$lwfi r_eff_i <- split_obj$r_eff_i - } - else { + } else { dim(log_liki) <- c(S_per_chain, N_chains, 1) r_eff_i <- loo::relative_eff(exp(log_liki), cores = 1) dim(log_liki) <- NULL @@ -407,25 +449,26 @@ loo_moment_match_i <- function(i, # pointwise estimates elpd_loo_i <- matrixStats::logSumExp(log_liki + lwi) mcse_elpd_loo <- mcse_elpd( - ll = as.matrix(log_liki), lw = as.matrix(lwi), - E_elpd = exp(elpd_loo_i), r_eff = r_eff_i + ll = as.matrix(log_liki), + lw = as.matrix(lwi), + E_elpd = exp(elpd_loo_i), + r_eff = r_eff_i ) - list(elpd_loo_i = elpd_loo_i, - p_loo = lpd - elpd_loo_i, - mcse_elpd_loo = mcse_elpd_loo, - looic = -2 * elpd_loo_i, - k = ki, - kf = kfi, - n_eff = min(1.0 / sum(exp(2 * lwi)), - 1.0 / sum(exp(2 * lwfi))) * r_eff_i, - lwi = lwi, - i = i) + list( + elpd_loo_i = elpd_loo_i, + p_loo = lpd - elpd_loo_i, + mcse_elpd_loo = mcse_elpd_loo, + looic = -2 * elpd_loo_i, + k = ki, + kf = kfi, + n_eff = min(1.0 / sum(exp(2 * lwi)), 1.0 / sum(exp(2 * lwfi))) * r_eff_i, + lwi = lwi, + i = i + ) } - - #' Update the importance weights, Pareto diagnostic and log-likelihood #' for observation `i` based on model `x`. #' @@ -449,9 +492,17 @@ loo_moment_match_i <- function(i, #' @return List with the updated importance weights, Pareto diagnostics and #' log-likelihood values. #' -update_quantities_i <- function(x, upars, i, orig_log_prob, - log_prob_upars, log_lik_i_upars, - r_eff_i, is_method, ...) { +update_quantities_i <- function( + x, + upars, + i, + orig_log_prob, + log_prob_upars, + log_lik_i_upars, + r_eff_i, + is_method, + ... +) { log_prob_new <- log_prob_upars(x, upars = upars, ...) log_liki_new <- log_lik_i_upars(x, upars = upars, i = i, ...) # compute new log importance weights @@ -460,17 +511,21 @@ update_quantities_i <- function(x, upars, i, orig_log_prob, # replace the log ratio with -Inf lr <- -log_liki_new + log_prob_new - orig_log_prob lr[is.na(lr)] <- -Inf - is_obj_new <- suppressWarnings(importance_sampling.default(lr, - method = is_method, - r_eff = r_eff_i, - cores = 1)) + is_obj_new <- suppressWarnings(importance_sampling.default( + lr, + method = is_method, + r_eff = r_eff_i, + cores = 1 + )) lwi_new <- as.vector(weights(is_obj_new)) ki_new <- is_obj_new$diagnostics$pareto_k - is_obj_f_new <- suppressWarnings(importance_sampling.default(log_prob_new - orig_log_prob, - method = is_method, - r_eff = r_eff_i, - cores = 1)) + is_obj_f_new <- suppressWarnings(importance_sampling.default( + log_prob_new - orig_log_prob, + method = is_method, + r_eff = r_eff_i, + cores = 1 + )) lwfi_new <- as.vector(weights(is_obj_f_new)) kfi_new <- is_obj_f_new$diagnostics$pareto_k @@ -485,7 +540,6 @@ update_quantities_i <- function(x, upars, i, orig_log_prob, } - #' Shift a matrix of parameters to their weighted mean. #' Also calls update_quantities_i which updates the importance weights based on #' the supplied model object. @@ -511,8 +565,6 @@ shift <- function(x, upars, lwi) { } - - #' Shift a matrix of parameters to their weighted mean and scale the marginal #' variances to match the weighted marginal variances. Also calls #' update_quantities_i which updates the importance weights based on @@ -533,9 +585,9 @@ shift_and_scale <- function(x, upars, lwi) { mean_original <- colMeans(upars) mean_weighted <- colSums(exp(lwi) * upars) shift <- mean_weighted - mean_original - mii <- exp(lwi)* upars^2 + mii <- exp(lwi) * upars^2 mii <- colSums(mii) - mean_weighted^2 - mii <- mii*S/(S-1) + mii <- mii * S / (S - 1) scaling <- sqrt(mii / matrixStats::colVars(upars)) # transform posterior draws upars_new <- sweep(upars, 2, mean_original, "-") @@ -573,15 +625,13 @@ shift_and_cov <- function(x, upars, lwi, ...) { { chol(wcovv) }, - error = function(cond) - { + error = function(cond) { return(NULL) } ) if (is.null(chol1)) { mapping <- diag(length(mean_original)) - } - else { + } else { chol2 <- chol(covv) mapping <- t(chol1) %*% solve(t(chol2)) } @@ -622,4 +672,3 @@ throw_large_kf_warning <- function(kf, k_threshold) { ) } } - diff --git a/R/loo_predictive_metric.R b/R/loo_predictive_metric.R index 8ee18bd2..0a894479 100644 --- a/R/loo_predictive_metric.R +++ b/R/loo_predictive_metric.R @@ -86,13 +86,15 @@ loo_predictive_metric <- function(x, ...) { #' @rdname loo_predictive_metric #' @export loo_predictive_metric.matrix <- - function(x, - y, - log_lik, - ..., - metric = c("mae", "rmse", "mse", "acc", "balanced_acc"), - r_eff = 1, - cores = getOption("mc.cores", 1)) { + function( + x, + y, + log_lik, + ..., + metric = c("mae", "rmse", "mse", "acc", "balanced_acc"), + r_eff = 1, + cores = getOption("mc.cores", 1) + ) { stopifnot( is.numeric(x), is.numeric(y), @@ -101,10 +103,12 @@ loo_predictive_metric.matrix <- ) metric <- match.arg(metric) psis_object <- psis(-log_lik, r_eff = r_eff, cores = cores) - pred_loo <- E_loo(x, - psis_object = psis_object, - log_ratios = -log_lik, - ...)$value + pred_loo <- E_loo( + x, + psis_object = psis_object, + log_ratios = -log_lik, + ... + )$value predictive_metric_fun <- .loo_predictive_metric_fun(metric) @@ -136,7 +140,7 @@ loo_predictive_metric.matrix <- #' @noRd #' @param y A vector of observed values #' @param yhat A vector of predictions -.mae <-function(y, yhat) { +.mae <- function(y, yhat) { stopifnot(length(y) == length(yhat)) n <- length(y) e <- abs(y - yhat) @@ -148,7 +152,7 @@ loo_predictive_metric.matrix <- #' @noRd #' @param y A vector of observed values #' @param yhat A vector of predictions -.mse <-function(y, yhat) { +.mse <- function(y, yhat) { stopifnot(length(y) == length(yhat)) n <- length(y) e <- (y - yhat)^2 @@ -160,7 +164,7 @@ loo_predictive_metric.matrix <- #' @noRd #' @param y A vector of observed values #' @param yhat A vector of predictions -.rmse <-function(y, yhat) { +.rmse <- function(y, yhat) { est <- .mse(y, yhat) mean_mse <- est$estimate var_mse <- est$se^2 @@ -174,14 +178,16 @@ loo_predictive_metric.matrix <- #' @param y A vector of observed values #' @param yhat A vector of predictions .accuracy <- function(y, yhat) { - stopifnot(length(y) == length(yhat), - all(y <= 1 & y >= 0), - all(yhat <= 1 & yhat >= 0)) + stopifnot( + length(y) == length(yhat), + all(y <= 1 & y >= 0), + all(yhat <= 1 & yhat >= 0) + ) n <- length(y) yhat <- as.integer(yhat > 0.5) acc <- as.integer(yhat == y) est <- mean(acc) - list(estimate = est, se = sqrt(est * (1-est) / n) ) + list(estimate = est, se = sqrt(est * (1 - est) / n)) } #' Balanced classification accuracy @@ -190,9 +196,11 @@ loo_predictive_metric.matrix <- #' @param y A vector of observed values #' @param yhat A vector of predictions .balanced_accuracy <- function(y, yhat) { - stopifnot(length(y) == length(yhat), - all(y <= 1 & y >= 0), - all(yhat <= 1 & yhat >= 0)) + stopifnot( + length(y) == length(yhat), + all(y <= 1 & y >= 0), + all(yhat <= 1 & yhat >= 0) + ) n <- length(y) yhat <- as.integer(yhat > 0.5) mask <- y == 0 @@ -205,4 +213,3 @@ loo_predictive_metric.matrix <- bls_acc_var <- (tp * (1 - tp) + tn * (1 - tn)) / 4 list(estimate = bls_acc, se = sqrt(bls_acc_var / n)) } - diff --git a/R/loo_subsample.R b/R/loo_subsample.R index d79bafa1..6f5fba20 100644 --- a/R/loo_subsample.R +++ b/R/loo_subsample.R @@ -100,46 +100,63 @@ loo_subsample <- function(x, ...) { #' with `loo_approximation = "waic_hess"`. The default is `NULL`. #' loo_subsample.function <- - function(x, - ..., - data = NULL, - draws = NULL, - observations = 400, - log_p = NULL, - log_g = NULL, - r_eff = 1, - save_psis = FALSE, - cores = getOption("mc.cores", 1), - loo_approximation = "plpd", - loo_approximation_draws = NULL, - estimator = "diff_srs", - llgrad = NULL, - llhess = NULL) { + function( + x, + ..., + data = NULL, + draws = NULL, + observations = 400, + log_p = NULL, + log_g = NULL, + r_eff = 1, + save_psis = FALSE, + cores = getOption("mc.cores", 1), + loo_approximation = "plpd", + loo_approximation_draws = NULL, + estimator = "diff_srs", + llgrad = NULL, + llhess = NULL + ) { cores <- loo_cores(cores) # Asserting inputs .llfun <- validate_llfun(x) stopifnot(is.data.frame(data) || is.matrix(data), !is.null(draws)) - observations <- assert_observations(observations, - N = dim(data)[1], - estimator) + observations <- assert_observations( + observations, + N = dim(data)[1], + estimator + ) checkmate::assert_numeric(log_p, len = length(log_g), null.ok = TRUE) checkmate::assert_null(dim(log_p)) checkmate::assert_numeric(log_g, len = length(log_p), null.ok = TRUE) checkmate::assert_null(dim(log_g)) if (is.null(log_p) && is.null(log_g)) { - r_eff <- prepare_psis_r_eff(r_eff, len = dim(data)[1]) + r_eff <- prepare_psis_r_eff(r_eff, len = dim(data)[1]) } checkmate::assert_flag(save_psis) cores <- loo_cores(cores) - checkmate::assert_choice(loo_approximation, choices = loo_approximation_choices(), null.ok = FALSE) - checkmate::assert_int(loo_approximation_draws, lower = 1, upper = .ndraws(draws), null.ok = TRUE) + checkmate::assert_choice( + loo_approximation, + choices = loo_approximation_choices(), + null.ok = FALSE + ) + checkmate::assert_int( + loo_approximation_draws, + lower = 1, + upper = .ndraws(draws), + null.ok = TRUE + ) checkmate::assert_choice(estimator, choices = estimator_choices()) .llgrad <- .llhess <- NULL - if (!is.null(llgrad)) .llgrad <- validate_llfun(llgrad) - if (!is.null(llhess)) .llhess <- validate_llfun(llhess) + if (!is.null(llgrad)) { + .llgrad <- validate_llfun(llgrad) + } + if (!is.null(llhess)) { + .llhess <- validate_llfun(llhess) + } # Fallbacks if (is.null(observations)) { @@ -192,7 +209,7 @@ loo_subsample.function <- # Compute idxs idxs <- compute_idxs(observations) } - data_subsample <- data[idxs$idx,, drop = FALSE] + data_subsample <- data[idxs$idx, , drop = FALSE] if (length(r_eff) > 1) { r_eff <- r_eff[idxs$idx] } @@ -220,17 +237,19 @@ loo_subsample.function <- } # Construct ss object and estimate - loo_ss <- psis_loo_ss_object(x = loo_obj, - idxs = idxs, - elpd_loo_approx = elpd_loo_approx, - loo_approximation = loo_approximation, - loo_approximation_draws = loo_approximation_draws, - estimator = estimator, - .llfun = .llfun, - .llgrad = .llgrad, - .llhess = .llhess, - data_dim = dim(data), - ndraws = .ndraws(draws)) + loo_ss <- psis_loo_ss_object( + x = loo_obj, + idxs = idxs, + elpd_loo_approx = elpd_loo_approx, + loo_approximation = loo_approximation, + loo_approximation_draws = loo_approximation_draws, + estimator = estimator, + .llfun = .llfun, + .llgrad = .llgrad, + .llhess = .llhess, + data_dim = dim(data), + ndraws = .ndraws(draws) + ) loo_ss } @@ -250,22 +269,29 @@ loo_subsample.function <- #' @param ... Currently not used. #' @return A `psis_loo_ss` object. #' @importFrom stats update -update.psis_loo_ss <- function(object, ..., - data = NULL, - draws = NULL, - observations = NULL, - r_eff = 1, - cores = getOption("mc.cores", 1), - loo_approximation = NULL, - loo_approximation_draws = NULL, - llgrad = NULL, - llhess = NULL) { +update.psis_loo_ss <- function( + object, + ..., + data = NULL, + draws = NULL, + observations = NULL, + r_eff = 1, + cores = getOption("mc.cores", 1), + loo_approximation = NULL, + loo_approximation_draws = NULL, + llgrad = NULL, + llhess = NULL +) { # Fallback - if (is.null(observations) & - is.null(loo_approximation) & - is.null(loo_approximation_draws) & - is.null(llgrad) & - is.null(llhess)) return(object) + if ( + is.null(observations) & + is.null(loo_approximation) & + is.null(loo_approximation_draws) & + is.null(llgrad) & + is.null(llhess) + ) { + return(object) + } if (!is.null(data)) { stopifnot(is.data.frame(data) || is.matrix(data)) @@ -282,35 +308,60 @@ update.psis_loo_ss <- function(object, ..., if (object$loo_subsampling$estimator %in% "hh_pps") { # HH estimation uses elpd_loo approx to sample, # so updating it will lead to incorrect results - stop("Can not update loo_approximation when using PPS sampling.", call. = FALSE) + stop( + "Can not update loo_approximation when using PPS sampling.", + call. = FALSE + ) + } + if (is.null(loo_approximation)) { + loo_approximation <- object$loo_subsampling$loo_approximation + } + if (is.null(loo_approximation_draws)) { + loo_approximation_draws <- object$loo_subsampling$loo_approximation_draws + } + if (is.null(llgrad)) { + .llgrad <- object$loo_subsampling$.llgrad + } else { + .llgrad <- validate_llfun(llgrad) + } + if (is.null(llhess)) { + .llhess <- object$loo_subsampling$.llhess + } else { + .llhess <- validate_llfun(llhess) } - if (is.null(loo_approximation)) loo_approximation <- object$loo_subsampling$loo_approximation - if (is.null(loo_approximation_draws)) loo_approximation_draws <- object$loo_subsampling$loo_approximation_draws - if (is.null(llgrad)) .llgrad <- object$loo_subsampling$.llgrad else .llgrad <- validate_llfun(llgrad) - if (is.null(llhess)) .llhess <- object$loo_subsampling$.llhess else .llhess <- validate_llfun(llhess) # Compute loo approximation elpd_loo_approx <- - elpd_loo_approximation(.llfun = object$loo_subsampling$.llfun, - data = data, draws = draws, - cores = cores, - loo_approximation = loo_approximation, - loo_approximation_draws = loo_approximation_draws, - .llgrad = .llgrad, .llhess = .llhess) + elpd_loo_approximation( + .llfun = object$loo_subsampling$.llfun, + data = data, + draws = draws, + cores = cores, + loo_approximation = loo_approximation, + loo_approximation_draws = loo_approximation_draws, + .llgrad = .llgrad, + .llhess = .llhess + ) # Update object object$loo_subsampling$elpd_loo_approx <- elpd_loo_approx object$loo_subsampling$loo_approximation <- loo_approximation - object$loo_subsampling["loo_approximation_draws"] <- list(loo_approximation_draws) + object$loo_subsampling["loo_approximation_draws"] <- list( + loo_approximation_draws + ) object$loo_subsampling$.llgrad <- .llgrad object$loo_subsampling$.llhess <- .llhess - object$pointwise[, "elpd_loo_approx"] <- object$loo_subsampling$elpd_loo_approx[object$pointwise[, "idx"]] + object$pointwise[, + "elpd_loo_approx" + ] <- object$loo_subsampling$elpd_loo_approx[object$pointwise[, "idx"]] } # Update observations if (!is.null(observations)) { - observations <- assert_observations(observations, - N = object$loo_subsampling$data_dim[1], - object$loo_subsampling$estimator) + observations <- assert_observations( + observations, + N = object$loo_subsampling$data_dim[1], + object$loo_subsampling$estimator + ) if (length(observations) == 1) { checkmate::assert_int(observations, lower = nobs(object) + 1) stopifnot(is.data.frame(data) || is.matrix(data) & !is.null(draws)) @@ -324,17 +375,25 @@ update.psis_loo_ss <- function(object, ..., # If sampling with replacement if (object$loo_subsampling$estimator %in% c("hh_pps")) { - idxs <- subsample_idxs(estimator = object$loo_subsampling$estimator, - elpd_loo_approximation = object$loo_subsampling$elpd_loo_approx, - observations = observations - current_obs) + idxs <- subsample_idxs( + estimator = object$loo_subsampling$estimator, + elpd_loo_approximation = object$loo_subsampling$elpd_loo_approx, + observations = observations - current_obs + ) } # If sampling without replacement if (object$loo_subsampling$estimator %in% c("diff_srs", "srs")) { current_idxs <- obs_idx(object, rep = FALSE) - new_idx <- (1:length(object$loo_subsampling$elpd_loo_approx))[-current_idxs] - idxs <- subsample_idxs(estimator = object$loo_subsampling$estimator, - elpd_loo_approximation = object$loo_subsampling$elpd_loo_approx[-current_idxs], - observations = observations - current_obs) + new_idx <- (1:length(object$loo_subsampling$elpd_loo_approx))[ + -current_idxs + ] + idxs <- subsample_idxs( + estimator = object$loo_subsampling$estimator, + elpd_loo_approximation = object$loo_subsampling$elpd_loo_approx[ + -current_idxs + ], + observations = observations - current_obs + ) idxs$idx <- new_idx[idxs$idx] } } @@ -345,30 +404,41 @@ update.psis_loo_ss <- function(object, ..., # Compute new observations if (!is.null(cidxs$new)) { stopifnot(is.data.frame(data) || is.matrix(data) & !is.null(draws)) - data_new_subsample <- data[cidxs$new$idx,, drop = FALSE] - if (length(r_eff) > 1) r_eff <- r_eff[cidxs$new$idx] - - if (!is.null(object$approximate_posterior$log_p) & !is.null(object$approximate_posterior$log_g)) { - loo_obj <- loo_approximate_posterior.function(x = object$loo_subsampling$.llfun, - data = data_new_subsample, - draws = draws, - log_p = object$approximate_posterior$log_p, - log_g = object$approximate_posterior$log_g, - save_psis = !is.null(object$psis_object), - cores = cores) + data_new_subsample <- data[cidxs$new$idx, , drop = FALSE] + if (length(r_eff) > 1) { + r_eff <- r_eff[cidxs$new$idx] + } + + if ( + !is.null(object$approximate_posterior$log_p) & + !is.null(object$approximate_posterior$log_g) + ) { + loo_obj <- loo_approximate_posterior.function( + x = object$loo_subsampling$.llfun, + data = data_new_subsample, + draws = draws, + log_p = object$approximate_posterior$log_p, + log_g = object$approximate_posterior$log_g, + save_psis = !is.null(object$psis_object), + cores = cores + ) } else { - loo_obj <- loo.function(x = object$loo_subsampling$.llfun, - data = data_new_subsample, - draws = draws, - r_eff = r_eff, - save_psis = !is.null(object$psis_object), - cores = cores) + loo_obj <- loo.function( + x = object$loo_subsampling$.llfun, + data = data_new_subsample, + draws = draws, + r_eff = r_eff, + save_psis = !is.null(object$psis_object), + cores = cores + ) } # Add stuff to pointwise loo_obj$pointwise <- - add_subsampling_vars_to_pointwise(loo_obj$pointwise, - cidxs$new, - object$loo_subsampling$elpd_loo_approx) + add_subsampling_vars_to_pointwise( + loo_obj$pointwise, + cidxs$new, + object$loo_subsampling$elpd_loo_approx + ) } else { loo_obj <- NULL } @@ -378,13 +448,21 @@ update.psis_loo_ss <- function(object, ..., object <- rbind_psis_loo_ss(object, x = loo_obj) # Update m_i for current pointwise (diagnostic stay the same) - object$pointwise <- update_m_i_in_pointwise(object$pointwise, cidxs$add, type = "add") + object$pointwise <- update_m_i_in_pointwise( + object$pointwise, + cidxs$add, + type = "add" + ) } else { # Add new samples pointwise and diagnostic object <- rbind_psis_loo_ss(object, loo_obj) # Replace m_i current pointwise and diagnostics - object$pointwise <- update_m_i_in_pointwise(object$pointwise, cidxs$add, type = "replace") + object$pointwise <- update_m_i_in_pointwise( + object$pointwise, + cidxs$add, + type = "replace" + ) # Remove samples object <- remove_idx.psis_loo_ss(object, idxs = cidxs$remove) @@ -395,7 +473,6 @@ update.psis_loo_ss <- function(object, ..., } } - # Compute estimates if (object$loo_subsampling$estimator == "hh_pps") { object <- loo_subsample_estimation_hh(object) @@ -425,9 +502,9 @@ update.psis_loo_ss <- function(object, ..., obs_idx <- function(x, rep = TRUE) { checkmate::assert_class(x, "psis_loo_ss") if (rep) { - idxs <- as.integer(rep(x$pointwise[,"idx"], x$pointwise[,"m_i"])) + idxs <- as.integer(rep(x$pointwise[, "idx"], x$pointwise[, "m_i"])) } else { - idxs <- as.integer(x$pointwise[,"idx"]) + idxs <- as.integer(x$pointwise[, "idx"]) } idxs } @@ -438,7 +515,7 @@ obs_idx <- function(x, rep = TRUE) { #' @param ... Currently unused. #' @export nobs.psis_loo_ss <- function(object, ...) { - as.integer(sum(object$pointwise[,"m_i"])) + as.integer(sum(object$pointwise[, "m_i"])) } # internal ---------------------------------------------------------------- @@ -454,8 +531,20 @@ nobs.psis_loo_ss <- function(object, ...) { #' @param api The choices available in the loo API or all possible choices. #' @return A character vector of allowed choices. loo_approximation_choices <- function(api = TRUE) { - lac <- c("plpd", "lpd", "waic", "waic_grad_marginal", "waic_grad", "waic_hess", "tis", "sis", "none") - if (!api) lac <- c(lac, "psis") + lac <- c( + "plpd", + "lpd", + "waic", + "waic_grad_marginal", + "waic_grad", + "waic_hess", + "tis", + "sis", + "none" + ) + if (!api) { + lac <- c(lac, "psis") + } lac } @@ -476,7 +565,7 @@ estimator_choices <- function() { #' #' @return lpd value for a single data point i lpd_i <- function(i, llfun, data, draws) { - ll_i <- llfun(data_i = data[i,, drop=FALSE], draws = draws) + ll_i <- llfun(data_i = data[i, , drop = FALSE], draws = draws) ll_i <- as.vector(ll_i) lpd_i <- logMeanExp(ll_i) lpd_i @@ -496,7 +585,14 @@ compute_lpds <- function(N, data, draws, llfun, cores) { lpds <- lapply(X = seq_len(N), FUN = lpd_i, llfun, data, draws) } else { if (.Platform$OS.type != "windows") { - lpds <- mclapply(X = seq_len(N), mc.cores = cores, FUN = lpd_i, llfun, data, draws) + lpds <- mclapply( + X = seq_len(N), + mc.cores = cores, + FUN = lpd_i, + llfun, + data, + draws + ) } else { cl <- makePSOCKcluster(cores) on.exit(stopCluster(cl)) @@ -515,33 +611,65 @@ compute_lpds <- function(N, data, draws, llfun, cores) { #' @inheritParams loo_subsample.function #' #' @return a vector with approximations of elpd_{loo,i}s -elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation, loo_approximation_draws = NULL, .llgrad = NULL, .llhess = NULL) { - checkmate::assert_function(.llfun, args = c("data_i", "draws"), ordered = TRUE) +elpd_loo_approximation <- function( + .llfun, + data, + draws, + cores, + loo_approximation, + loo_approximation_draws = NULL, + .llgrad = NULL, + .llhess = NULL +) { + checkmate::assert_function( + .llfun, + args = c("data_i", "draws"), + ordered = TRUE + ) stopifnot(is.data.frame(data) || is.matrix(data), !is.null(draws)) - checkmate::assert_choice(loo_approximation, choices = loo_approximation_choices(), null.ok = FALSE) + checkmate::assert_choice( + loo_approximation, + choices = loo_approximation_choices(), + null.ok = FALSE + ) checkmate::assert_int(loo_approximation_draws, lower = 2, null.ok = TRUE) if (!is.null(.llgrad)) { - checkmate::assert_function(.llgrad, args = c("data_i", "draws"), ordered = TRUE) + checkmate::assert_function( + .llgrad, + args = c("data_i", "draws"), + ordered = TRUE + ) } if (!is.null(.llhess)) { - checkmate::assert_function(.llhess, args = c("data_i", "draws"), ordered = TRUE) + checkmate::assert_function( + .llhess, + args = c("data_i", "draws"), + ordered = TRUE + ) } cores <- loo_cores(cores) N <- dim(data)[1] - if (loo_approximation == "none") return(rep(1L,N)) + if (loo_approximation == "none") { + return(rep(1L, N)) + } if (loo_approximation %in% c("tis", "sis")) { draws <- .thin_draws(draws, loo_approximation_draws) - is_values <- suppressWarnings(loo.function(.llfun, data = data, draws = draws, is_method = loo_approximation)) + is_values <- suppressWarnings(loo.function( + .llfun, + data = data, + draws = draws, + is_method = loo_approximation + )) return(is_values$pointwise[, "elpd_loo"]) } if (loo_approximation == "waic") { draws <- .thin_draws(draws, loo_approximation_draws) waic_full_obj <- waic.function(.llfun, data = data, draws = draws) - return(waic_full_obj$pointwise[,"elpd_waic"]) + return(waic_full_obj$pointwise[, "elpd_waic"]) } # Compute the lpd or log p(y_i|y_{-i}) @@ -552,28 +680,33 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation } # Compute the point lpd or log p(y_i|\hat{\theta}) - also used in waic_delta approaches - if (loo_approximation == "plpd" | + if ( + loo_approximation == "plpd" | loo_approximation == "waic_grad" | loo_approximation == "waic_grad_marginal" | - loo_approximation == "waic_hess") { - + loo_approximation == "waic_hess" + ) { draws <- .thin_draws(draws, loo_approximation_draws) point_est <- .compute_point_estimate(draws) lpds <- compute_lpds(N, data, point_est, .llfun, cores) if (loo_approximation == "plpd") return(lpds) # Use only the lpd } - if (loo_approximation == "waic_grad" | + if ( + loo_approximation == "waic_grad" | loo_approximation == "waic_grad_marginal" | - loo_approximation == "waic_hess") { + loo_approximation == "waic_hess" + ) { checkmate::assert_true(!is.null(.llgrad)) point_est <- .compute_point_estimate(draws) # Compute the lpds lpds <- compute_lpds(N, data, point_est, .llfun, cores) - if (loo_approximation == "waic_grad" | - loo_approximation == "waic_hess") { + if ( + loo_approximation == "waic_grad" | + loo_approximation == "waic_hess" + ) { cov_est <- stats::cov(draws) } @@ -582,27 +715,33 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation } p_eff_approx <- numeric(N) - if (cores>1) warning("Multicore is not implemented for waic_delta", - call. = FALSE) + if (cores > 1) { + warning("Multicore is not implemented for waic_delta", call. = FALSE) + } if (loo_approximation == "waic_grad") { - for(i in 1:nrow(data)) { - grad_i <- t(.llgrad(data[i,,drop = FALSE], point_est)) + for (i in 1:nrow(data)) { + grad_i <- t(.llgrad(data[i, , drop = FALSE], point_est)) local_cov <- cov_est[rownames(grad_i), rownames(grad_i)] - p_eff_approx[i] <- t(grad_i) %*% local_cov %*% grad_i + p_eff_approx[i] <- t(grad_i) %*% local_cov %*% grad_i } } else if (loo_approximation == "waic_grad_marginal") { - for(i in 1:nrow(data)) { - grad_i <- t(.llgrad(data[i,,drop = FALSE], point_est)) + for (i in 1:nrow(data)) { + grad_i <- t(.llgrad(data[i, , drop = FALSE], point_est)) p_eff_approx[i] <- sum(grad_i * marg_vars[rownames(grad_i)] * grad_i) } } else if (loo_approximation == "waic_hess") { checkmate::assert_true(!is.null(.llhess)) - for(i in 1:nrow(data)) { - grad_i <- t(.llgrad(data[i,,drop = FALSE], point_est)) - hess_i <- .llhess(data_i = data[i,,drop = FALSE], draws = point_est[,rownames(grad_i), drop = FALSE])[,,1] + for (i in 1:nrow(data)) { + grad_i <- t(.llgrad(data[i, , drop = FALSE], point_est)) + hess_i <- .llhess( + data_i = data[i, , drop = FALSE], + draws = point_est[, rownames(grad_i), drop = FALSE] + )[,, 1] local_cov <- cov_est[rownames(grad_i), rownames(grad_i)] - p_eff_approx[i] <- t(grad_i) %*% local_cov %*% grad_i + + p_eff_approx[i] <- t(grad_i) %*% + local_cov %*% + grad_i + 0.5 * sum(diag(local_cov %*% hess_i %*% local_cov %*% hess_i)) } } else { @@ -610,7 +749,6 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation } return(lpds - p_eff_approx) } - } @@ -635,7 +773,11 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation #' @rdname dot-compute_point_estimate #' @export .compute_point_estimate.default <- function(draws) { - stop(".compute_point_estimate() has not been implemented for objects of class '", class(draws), "'") + stop( + ".compute_point_estimate() has not been implemented for objects of class '", + class(draws), + "'" + ) } #' Thin a draws object @@ -655,8 +797,15 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation #' @rdname dot-thin_draws #' @export .thin_draws.matrix <- function(draws, loo_approximation_draws) { - if (is.null(loo_approximation_draws)) return(draws) - checkmate::assert_int(loo_approximation_draws, lower = 1, upper = .ndraws(draws), null.ok = TRUE) + if (is.null(loo_approximation_draws)) { + return(draws) + } + checkmate::assert_int( + loo_approximation_draws, + lower = 1, + upper = .ndraws(draws), + null.ok = TRUE + ) S <- .ndraws(draws) idx <- 1:loo_approximation_draws * S %/% loo_approximation_draws draws <- draws[idx, , drop = FALSE] @@ -670,7 +819,11 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation #' @rdname dot-thin_draws #' @export .thin_draws.default <- function(draws, loo_approximation_draws) { - stop(".thin_draws() has not been implemented for objects of class '", class(draws), "'") + stop( + ".thin_draws() has not been implemented for objects of class '", + class(draws), + "'" + ) } @@ -695,7 +848,11 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation #' @rdname dot-ndraws #' @export .ndraws.default <- function(x) { - stop(".ndraws() has not been implemented for objects of class '", class(x), "'") + stop( + ".ndraws() has not been implemented for objects of class '", + class(x), + "'" + ) } ## Subsampling ----- @@ -719,12 +876,17 @@ subsample_idxs <- function(estimator, elpd_loo_approximation, observations) { if (estimator == "diff_srs" | estimator == "srs") { if (observations > length(elpd_loo_approximation)) { - stop("'observations' is larger than the total sample size in 'data'.", call. = FALSE) + stop( + "'observations' is larger than the total sample size in 'data'.", + call. = FALSE + ) } idx <- 1:length(elpd_loo_approximation) - idx_m <- idx[order(stats::runif(length(elpd_loo_approximation)))][1:observations] + idx_m <- idx[order(stats::runif(length(elpd_loo_approximation)))][ + 1:observations + ] idx_m <- idx_m[order(idx_m)] - idxs_df <- data.frame(idx=as.integer(idx_m), m_i=1L) + idxs_df <- data.frame(idx = as.integer(idx_m), m_i = 1L) } assert_subsample_idxs(x = idxs_df) idxs_df @@ -738,7 +900,7 @@ subsample_idxs <- function(estimator, elpd_loo_approximation, observations) { pps_elpd_loo_approximation_to_pis <- function(elpd_loo_approximation) { checkmate::assert_numeric(elpd_loo_approximation) pi_values <- abs(elpd_loo_approximation) - pi_values <- pi_values/sum(pi_values) # \tilde{\pi} + pi_values <- pi_values / sum(pi_values) # \tilde{\pi} pi_values } @@ -748,9 +910,17 @@ pps_elpd_loo_approximation_to_pis <- function(elpd_loo_approximation) { #' @param observation A vector of indices. #' @return A `subsample_idxs` data frame. compute_idxs <- function(observations) { - checkmate::assert_integer(observations, lower = 1, min.len = 2, any.missing = FALSE) + checkmate::assert_integer( + observations, + lower = 1, + min.len = 2, + any.missing = FALSE + ) tab <- table(observations) - idxs_df <- data.frame(idx = as.integer(names(tab)), m_i = as.integer(unname(tab))) + idxs_df <- data.frame( + idx = as.integer(names(tab)), + m_i = as.integer(unname(tab)) + ) assert_subsample_idxs(idxs_df) idxs_df } @@ -767,7 +937,7 @@ compute_idxs <- function(observations) { #' @param object A `psis_loo_ss` object. #' @return A list of three `subsample_idxs` data frames. Elements without any #' observations return `NULL`. -compare_idxs <- function(idxs, object) { +compare_idxs <- function(idxs, object) { assert_subsample_idxs(idxs) current_idx <- compute_idxs(obs_idx(object)) result <- list() @@ -833,13 +1003,19 @@ pps_sample <- function(m, pis) { #' @param data_dim Dimension of the data object. #' @param ndraws Dimension of the draws object. #' @return A `psis_loo_ss` object. -psis_loo_ss_object <- function(x, - idxs, - elpd_loo_approx, - loo_approximation, loo_approximation_draws, - estimator, - .llfun, .llgrad, .llhess, - data_dim, ndraws) { +psis_loo_ss_object <- function( + x, + idxs, + elpd_loo_approx, + loo_approximation, + loo_approximation_draws, + estimator, + .llfun, + .llgrad, + .llhess, + data_dim, + ndraws +) { # Assertions checkmate::assert_class(x, "psis_loo") assert_subsample_idxs(idxs) @@ -847,15 +1023,33 @@ psis_loo_ss_object <- function(x, checkmate::assert_choice(loo_approximation, loo_approximation_choices()) checkmate::assert_int(loo_approximation_draws, null.ok = TRUE) checkmate::assert_choice(estimator, estimator_choices()) - checkmate::assert_function(.llfun, args = c("data_i", "draws"), ordered = TRUE) - checkmate::assert_function(.llgrad, args = c("data_i", "draws"), ordered = TRUE, null.ok = TRUE) - checkmate::assert_function(.llhess, args = c("data_i", "draws"), ordered = TRUE, null.ok = TRUE) + checkmate::assert_function( + .llfun, + args = c("data_i", "draws"), + ordered = TRUE + ) + checkmate::assert_function( + .llgrad, + args = c("data_i", "draws"), + ordered = TRUE, + null.ok = TRUE + ) + checkmate::assert_function( + .llhess, + args = c("data_i", "draws"), + ordered = TRUE, + null.ok = TRUE + ) checkmate::assert_integer(data_dim, len = 2, lower = 1, any.missing = FALSE) checkmate::assert_int(ndraws, lower = 1) # Construct object class(x) <- c("psis_loo_ss", class(x)) - x$pointwise <- add_subsampling_vars_to_pointwise(pointwise = x$pointwise, idxs, elpd_loo_approx) + x$pointwise <- add_subsampling_vars_to_pointwise( + pointwise = x$pointwise, + idxs, + elpd_loo_approx + ) x$estimates <- cbind(x$estimates, matrix(0, nrow = nrow(x$estimates))) colnames(x$estimates)[ncol(x$estimates)] <- "subsampling SE" @@ -896,18 +1090,22 @@ as.psis_loo_ss.psis_loo <- function(x) { class(x) <- c("psis_loo_ss", class(x)) x$estimates <- cbind(x$estimates, matrix(0, nrow = nrow(x$estimates))) colnames(x$estimates)[ncol(x$estimates)] <- "subsampling SE" - x$pointwise <- cbind(x$pointwise, - matrix(1:nrow(x$pointwise), byrow = FALSE, ncol = 1), - matrix(rep(1,nrow(x$pointwise)), byrow = FALSE, ncol = 1), - x$pointwise[, "elpd_loo"]) + x$pointwise <- cbind( + x$pointwise, + matrix(1:nrow(x$pointwise), byrow = FALSE, ncol = 1), + matrix(rep(1, nrow(x$pointwise)), byrow = FALSE, ncol = 1), + x$pointwise[, "elpd_loo"] + ) ncp <- ncol(x$pointwise) - colnames(x$pointwise)[(ncp-2):ncp] <- c("idx", "m_i", "elpd_loo_approx") - x$loo_subsampling <- list(elpd_loo_approx=x$pointwise[, "elpd_loo"], - loo_approximation = "psis", - loo_approximation_draws = NULL, - estimator = "diff_srs", - data_dim = c(nrow(x$pointwise), NA), - ndraws = NA) + colnames(x$pointwise)[(ncp - 2):ncp] <- c("idx", "m_i", "elpd_loo_approx") + x$loo_subsampling <- list( + elpd_loo_approx = x$pointwise[, "elpd_loo"], + loo_approximation = "psis", + loo_approximation_draws = NULL, + estimator = "diff_srs", + data_dim = c(nrow(x$pointwise), NA), + ndraws = NA + ) assert_psis_loo_ss(x) x } @@ -926,20 +1124,27 @@ as.psis_loo.psis_loo_ss <- function(x) { x$estimates <- x$estimates[, 1:2] x$pointwise <- x$pointwise[, 1:5] x$loo_subsampling <- NULL - loo_obj <- importance_sampling_loo_object(pointwise = x$pointwise[, 1:5], - diagnostics = x$diagnostics, - dims = attr(x, "dims"), - is_method = "psis", - is_object = x$psis_object) + loo_obj <- importance_sampling_loo_object( + pointwise = x$pointwise[, 1:5], + diagnostics = x$diagnostics, + dims = attr(x, "dims"), + is_method = "psis", + is_object = x$psis_object + ) if (inherits(x, "psis_loo_ap")) { - loo_obj$approximate_posterior <- list(log_p = x$approximate_posterior$log_p, - log_g = x$approximate_posterior$log_g) + loo_obj$approximate_posterior <- list( + log_p = x$approximate_posterior$log_p, + log_g = x$approximate_posterior$log_g + ) class(loo_obj) <- c("psis_loo_ap", class(loo_obj)) assert_psis_loo_ap(loo_obj) } } else { - stop("A subsampling loo object can only be coerced to a loo object ", - "if all observations in data have been subsampled.", call. = FALSE) + stop( + "A subsampling loo object can only be coerced to a loo object ", + "if all observations in data have been subsampled.", + call. = FALSE + ) } loo_obj @@ -951,11 +1156,22 @@ as.psis_loo.psis_loo_ss <- function(x) { #' @param idxs A `subsample_idxs` data frame. #' @param elpd_loo_approximation A vector of loo approximations, see `elpd_loo_approximation()`. #' @return A `pointwise` matrix with subsampling information. -add_subsampling_vars_to_pointwise <- function(pointwise, idxs, elpd_loo_approx) { - checkmate::assert_matrix(pointwise, - any.missing = FALSE, - min.cols = 5) - checkmate::assert_names(colnames(pointwise), identical.to = c("elpd_loo","mcse_elpd_loo","p_loo","looic", "influence_pareto_k")) +add_subsampling_vars_to_pointwise <- function( + pointwise, + idxs, + elpd_loo_approx +) { + checkmate::assert_matrix(pointwise, any.missing = FALSE, min.cols = 5) + checkmate::assert_names( + colnames(pointwise), + identical.to = c( + "elpd_loo", + "mcse_elpd_loo", + "p_loo", + "looic", + "influence_pareto_k" + ) + ) assert_subsample_idxs(idxs) checkmate::assert_numeric(elpd_loo_approx) @@ -974,7 +1190,9 @@ add_subsampling_vars_to_pointwise <- function(pointwise, idxs, elpd_loo_approx) #' @return An updated `psis_loo_ss` object. rbind_psis_loo_ss <- function(object, x) { checkmate::assert_class(object, "psis_loo_ss") - if (is.null(x)) return(object) # Fallback + if (is.null(x)) { + return(object) + } # Fallback checkmate::assert_class(x, "psis_loo") assert_subsampling_pointwise(object$pointwise) assert_subsampling_pointwise(x$pointwise) @@ -996,7 +1214,9 @@ rbind_psis_loo_ss <- function(object, x) { #' @return A `psis_loo_ss` object. remove_idx.psis_loo_ss <- function(object, idxs) { checkmate::assert_class(object, "psis_loo_ss") - if (is.null(idxs)) return(object) # Fallback + if (is.null(idxs)) { + return(object) + } # Fallback assert_subsample_idxs(idxs) row_map <- data.frame( @@ -1005,7 +1225,7 @@ remove_idx.psis_loo_ss <- function(object, idxs) { ) row_map <- merge(row_map, idxs, by = "idx", all.y = TRUE) - object$pointwise <- object$pointwise[-row_map$row_no,,drop = FALSE] + object$pointwise <- object$pointwise[-row_map$row_no, , drop = FALSE] object$diagnostics$pareto_k <- object$diagnostics$pareto_k[-row_map$row_no] object$diagnostics$n_eff <- object$diagnostics$n_eff[-row_map$row_no] object$diagnostics$r_eff <- object$diagnostics$r_eff[-row_map$row_no] @@ -1021,13 +1241,21 @@ remove_idx.psis_loo_ss <- function(object, idxs) { order.psis_loo_ss <- function(x, observations) { checkmate::assert_class(x, "psis_loo_ss") checkmate::assert_integer(observations, len = nobs(x)) - if (identical(obs_idx(x), observations)) return(x) # Fallback + if (identical(obs_idx(x), observations)) { + return(x) + } # Fallback checkmate::assert_set_equal(obs_idx(x), observations) - row_map_x <- data.frame(row_no_x = 1:nrow(x$pointwise), idx = x$pointwise[, "idx"]) - row_map_obs <- data.frame(row_no_obs = 1:length(observations), idx = observations) + row_map_x <- data.frame( + row_no_x = 1:nrow(x$pointwise), + idx = x$pointwise[, "idx"] + ) + row_map_obs <- data.frame( + row_no_obs = 1:length(observations), + idx = observations + ) row_map <- merge(row_map_obs, row_map_x, by = "idx", sort = FALSE) - x$pointwise <- x$pointwise[row_map$row_no_x,,drop = FALSE] + x$pointwise <- x$pointwise[row_map$row_no_x, , drop = FALSE] x$diagnostics$pareto_k <- x$diagnostics$pareto_k[row_map$row_no_x] x$diagnostics$n_eff <- x$diagnostics$n_eff[row_map$row_no_x] x$diagnostics$r_eff <- x$diagnostics$r_eff[row_map$row_no_x] @@ -1043,7 +1271,9 @@ order.psis_loo_ss <- function(x, observations) { #' @return An ordered `psis_loo_ss` object. update_m_i_in_pointwise <- function(pointwise, idxs, type = "replace") { assert_subsampling_pointwise(pointwise) - if (is.null(idxs)) return(pointwise) # Fallback + if (is.null(idxs)) { + return(pointwise) + } # Fallback assert_subsample_idxs(idxs) checkmate::assert_choice(type, choices = c("replace", "add")) @@ -1054,13 +1284,13 @@ update_m_i_in_pointwise <- function(pointwise, idxs, type = "replace") { pointwise[row_map$row_no, "m_i"] <- row_map$m_i } if (type == "add") { - pointwise[row_map$row_no, "m_i"] <- pointwise[row_map$row_no, "m_i"] + row_map$m_i + pointwise[row_map$row_no, "m_i"] <- pointwise[row_map$row_no, "m_i"] + + row_map$m_i } pointwise } - ## Estimation --- #' Estimate the elpd using the Hansen-Hurwitz estimator (Magnusson et al., 2019) @@ -1071,26 +1301,42 @@ loo_subsample_estimation_hh <- function(x) { checkmate::assert_class(x, "psis_loo_ss") N <- length(x$loo_subsampling$elpd_loo_approx) pis <- pps_elpd_loo_approximation_to_pis(x$loo_subsampling$elpd_loo_approx) - pis_sample <- pis[x$pointwise[,"idx"]] + pis_sample <- pis[x$pointwise[, "idx"]] - hh_elpd_loo <- whhest(z = pis_sample, m_i = x$pointwise[, "m_i"], y = x$pointwise[, "elpd_loo"], N) + hh_elpd_loo <- whhest( + z = pis_sample, + m_i = x$pointwise[, "m_i"], + y = x$pointwise[, "elpd_loo"], + N + ) srs_elpd_loo <- srs_est(y = x$pointwise[, "elpd_loo"], y_approx = pis_sample) - x$estimates["elpd_loo", "Estimate"] <- hh_elpd_loo$y_hat_ppz + x$estimates["elpd_loo", "Estimate"] <- hh_elpd_loo$y_hat_ppz if (hh_elpd_loo$hat_v_y_ppz > 0) { - x$estimates["elpd_loo", "SE"] <- sqrt(hh_elpd_loo$hat_v_y_ppz) + x$estimates["elpd_loo", "SE"] <- sqrt(hh_elpd_loo$hat_v_y_ppz) } else { - warning("Negative estimate of SE, more subsampling obs. needed.", call. = FALSE) - x$estimates["elpd_loo", "SE"] <- NaN + warning( + "Negative estimate of SE, more subsampling obs. needed.", + call. = FALSE + ) + x$estimates["elpd_loo", "SE"] <- NaN } x$estimates["elpd_loo", "subsampling SE"] <- sqrt(hh_elpd_loo$v_hat_y_ppz) - hh_p_loo <- whhest(z = pis_sample, m_i = x$pointwise[,"m_i"], y = x$pointwise[,"p_loo"], N) + hh_p_loo <- whhest( + z = pis_sample, + m_i = x$pointwise[, "m_i"], + y = x$pointwise[, "p_loo"], + N + ) x$estimates["p_loo", "Estimate"] <- hh_p_loo$y_hat_ppz if (hh_p_loo$hat_v_y_ppz > 0) { - x$estimates["p_loo", "SE"] <- sqrt(hh_p_loo$hat_v_y_ppz) + x$estimates["p_loo", "SE"] <- sqrt(hh_p_loo$hat_v_y_ppz) } else { - warning("Negative estimate of SE, more subsampling obs. needed.", call. = FALSE) - x$estimates["elpd_loo", "SE"] <- NaN + warning( + "Negative estimate of SE, more subsampling obs. needed.", + call. = FALSE + ) + x$estimates["elpd_loo", "SE"] <- NaN } x$estimates["p_loo", "subsampling SE"] <- sqrt(hh_p_loo$v_hat_y_ppz) update_psis_loo_ss_estimates(x) @@ -1109,7 +1355,8 @@ update_psis_loo_ss_estimates <- function(x) { x$estimates["looic", "Estimate"] <- (-2) * x$estimates["elpd_loo", "Estimate"] x$estimates["looic", "SE"] <- 2 * x$estimates["elpd_loo", "SE"] - x$estimates["looic", "subsampling SE"] <- 2 * x$estimates["elpd_loo", "subsampling SE"] + x$estimates["looic", "subsampling SE"] <- 2 * + x$estimates["elpd_loo", "subsampling SE"] x$elpd_loo <- x$estimates["elpd_loo", "Estimate"] x$p_loo <- x$estimates["p_loo", "Estimate"] @@ -1133,13 +1380,16 @@ whhest <- function(z, m_i, y, N) { checkmate::assert_numeric(y, len = length(z)) checkmate::assert_integerish(m_i, len = length(z)) est_list <- list(m = sum(m_i)) - est_list$y_hat_ppz <- sum(m_i*(y/z))/est_list$m - est_list$v_hat_y_ppz <- (sum(m_i*((y/z - est_list$y_hat_ppz)^2))/est_list$m)/(est_list$m-1) + est_list$y_hat_ppz <- sum(m_i * (y / z)) / est_list$m + est_list$v_hat_y_ppz <- (sum(m_i * ((y / z - est_list$y_hat_ppz)^2)) / + est_list$m) / + (est_list$m - 1) # See unbiadness proof in supplementary material to the article est_list$hat_v_y_ppz <- - (sum(m_i*(y^2/z)) / est_list$m) + - est_list$v_hat_y_ppz / N - est_list$y_hat_ppz^2 / N + (sum(m_i * (y^2 / z)) / est_list$m) + + est_list$v_hat_y_ppz / N - + est_list$y_hat_ppz^2 / N est_list } @@ -1151,12 +1401,19 @@ whhest <- function(z, m_i, y, N) { loo_subsample_estimation_diff_srs <- function(x) { checkmate::assert_class(x, "psis_loo_ss") - elpd_loo_est <- srs_diff_est(y_approx = x$loo_subsampling$elpd_loo_approx, y = x$pointwise[, "elpd_loo"], y_idx = x$pointwise[, "idx"]) + elpd_loo_est <- srs_diff_est( + y_approx = x$loo_subsampling$elpd_loo_approx, + y = x$pointwise[, "elpd_loo"], + y_idx = x$pointwise[, "idx"] + ) x$estimates["elpd_loo", "Estimate"] <- elpd_loo_est$y_hat x$estimates["elpd_loo", "SE"] <- sqrt(elpd_loo_est$hat_v_y) x$estimates["elpd_loo", "subsampling SE"] <- sqrt(elpd_loo_est$v_y_hat) - p_loo_est <- srs_est(y = x$pointwise[, "p_loo"], y_approx = x$loo_subsampling$elpd_loo_approx) + p_loo_est <- srs_est( + y = x$pointwise[, "p_loo"], + y_approx = x$loo_subsampling$elpd_loo_approx + ) x$estimates["p_loo", "Estimate"] <- p_loo_est$y_hat x$estimates["p_loo", "SE"] <- sqrt(p_loo_est$hat_v_y) x$estimates["p_loo", "subsampling SE"] <- sqrt(p_loo_est$v_y_hat) @@ -1195,7 +1452,11 @@ srs_diff_est <- function(y_approx, y, y_idx) { # Here the variance is for sum, while in the paper the variance is for mean # which explains the proportional difference of 1/N est_list$hat_v_y <- (t_pi2_tilde + t_hat_epsilon) - # a (has been checked) - (1/N) * (t_e^2 - est_list$v_y_hat + 2 * t_pi_tilde * est_list$y_hat - t_pi_tilde^2) # b + (1 / N) * + (t_e^2 - + est_list$v_y_hat + + 2 * t_pi_tilde * est_list$y_hat - + t_pi_tilde^2) # b est_list } @@ -1208,12 +1469,18 @@ srs_diff_est <- function(y_approx, y, y_idx) { loo_subsample_estimation_srs <- function(x) { checkmate::assert_class(x, "psis_loo_ss") - elpd_loo_est <- srs_est(y = x$pointwise[, "elpd_loo"], y_approx = x$loo_subsampling$elpd_loo_approx) + elpd_loo_est <- srs_est( + y = x$pointwise[, "elpd_loo"], + y_approx = x$loo_subsampling$elpd_loo_approx + ) x$estimates["elpd_loo", "Estimate"] <- elpd_loo_est$y_hat x$estimates["elpd_loo", "SE"] <- sqrt(elpd_loo_est$hat_v_y) x$estimates["elpd_loo", "subsampling SE"] <- sqrt(elpd_loo_est$v_y_hat) - p_loo_est <- srs_est(y = x$pointwise[, "p_loo"], y_approx = x$loo_subsampling$elpd_loo_approx) + p_loo_est <- srs_est( + y = x$pointwise[, "p_loo"], + y_approx = x$loo_subsampling$elpd_loo_approx + ) x$estimates["p_loo", "Estimate"] <- p_loo_est$y_hat x$estimates["p_loo", "SE"] <- sqrt(p_loo_est$hat_v_y) x$estimates["p_loo", "subsampling SE"] <- sqrt(p_loo_est$v_y_hat) @@ -1233,14 +1500,13 @@ srs_est <- function(y, y_approx) { m <- length(y) est_list <- list(m = m) est_list$y_hat <- N * mean(y) - est_list$v_y_hat <- N^2 * (1-m/N) * var(y)/m + est_list$v_y_hat <- N^2 * (1 - m / N) * var(y) / m est_list$hat_v_y <- N * var(y) est_list } - ## Specialized assertions of objects --- #' Assert that the object has the expected properties @@ -1252,7 +1518,9 @@ srs_est <- function(y, y_approx) { assert_observations <- function(x, N, estimator) { checkmate::assert_int(N) checkmate::assert_choice(estimator, choices = estimator_choices()) - if (is.null(x)) return(x) + if (is.null(x)) { + return(x) + } if (checkmate::test_class(x, "psis_loo_ss")) { x <- obs_idx(x) checkmate::assert_integer(x, lower = 1, upper = N, any.missing = FALSE) @@ -1262,7 +1530,9 @@ assert_observations <- function(x, N, estimator) { if (length(x) > 1) { checkmate::assert_integer(x, lower = 1, upper = N, any.missing = FALSE) if (estimator %in% "hh_pps") { - message("Sampling proportional to elpd approximation and with replacement assumed.") + message( + "Sampling proportional to elpd approximation and with replacement assumed." + ) } if (estimator %in% c("diff_srs", "srs")) { message("Simple random sampling with replacement assumed.") @@ -1278,13 +1548,20 @@ assert_observations <- function(x, N, estimator) { #' @inheritParams assert_observations #' @return An asserted object of `x`. assert_subsample_idxs <- function(x) { - checkmate::assert_data_frame(x, - types = c("integer", "integer"), - any.missing = FALSE, - min.rows = 1, - col.names = "named") + checkmate::assert_data_frame( + x, + types = c("integer", "integer"), + any.missing = FALSE, + min.rows = 1, + col.names = "named" + ) checkmate::assert_names(names(x), identical.to = c("idx", "m_i")) - checkmate::assert_integer(x$idx, lower = 1, any.missing = FALSE, unique = TRUE) + checkmate::assert_integer( + x$idx, + lower = 1, + any.missing = FALSE, + unique = TRUE + ) checkmate::assert_integer(x$m_i, lower = 1, any.missing = FALSE) x } @@ -1295,22 +1572,64 @@ assert_subsample_idxs <- function(x) { #' @return An asserted object of `x`. assert_psis_loo_ss <- function(x) { checkmate::assert_class(x, "psis_loo_ss") - checkmate::assert_names(names(x), must.include = c("estimates", "pointwise", "diagnostics", "psis_object", "loo_subsampling")) - checkmate::assert_names(rownames(x$estimates), must.include = c("elpd_loo", "p_loo", "looic")) - checkmate::assert_names(colnames(x$estimates), must.include = c("Estimate", "SE", "subsampling SE")) + checkmate::assert_names( + names(x), + must.include = c( + "estimates", + "pointwise", + "diagnostics", + "psis_object", + "loo_subsampling" + ) + ) + checkmate::assert_names( + rownames(x$estimates), + must.include = c("elpd_loo", "p_loo", "looic") + ) + checkmate::assert_names( + colnames(x$estimates), + must.include = c("Estimate", "SE", "subsampling SE") + ) assert_subsampling_pointwise(x$pointwise) - checkmate::assert_names(names(x$loo_subsampling), - must.include = c("elpd_loo_approx", - "loo_approximation", "loo_approximation_draws", - "estimator", - "data_dim", "ndraws")) - checkmate::assert_numeric(x$loo_subsampling$elpd_loo_approx, any.missing = FALSE, len = x$loo_subsampling$data_dim[1]) - checkmate::assert_choice(x$loo_subsampling$loo_approximation, choices = loo_approximation_choices(api = FALSE)) - checkmate::assert_int(x$loo_subsampling$loo_approximation_draws, null.ok = TRUE) - checkmate::assert_choice(x$loo_subsampling$estimator, choices = estimator_choices()) - checkmate::assert_integer(x$loo_subsampling$data_dim, any.missing = TRUE, len = 2) + checkmate::assert_names( + names(x$loo_subsampling), + must.include = c( + "elpd_loo_approx", + "loo_approximation", + "loo_approximation_draws", + "estimator", + "data_dim", + "ndraws" + ) + ) + checkmate::assert_numeric( + x$loo_subsampling$elpd_loo_approx, + any.missing = FALSE, + len = x$loo_subsampling$data_dim[1] + ) + checkmate::assert_choice( + x$loo_subsampling$loo_approximation, + choices = loo_approximation_choices(api = FALSE) + ) + checkmate::assert_int( + x$loo_subsampling$loo_approximation_draws, + null.ok = TRUE + ) + checkmate::assert_choice( + x$loo_subsampling$estimator, + choices = estimator_choices() + ) + checkmate::assert_integer( + x$loo_subsampling$data_dim, + any.missing = TRUE, + len = 2 + ) checkmate::assert_int(x$loo_subsampling$data_dim[1], na.ok = FALSE) - checkmate::assert_integer(x$loo_subsampling$ndraws, len = 1, any.missing = TRUE) + checkmate::assert_integer( + x$loo_subsampling$ndraws, + len = 1, + any.missing = TRUE + ) x } @@ -1319,9 +1638,19 @@ assert_psis_loo_ss <- function(x) { #' @inheritParams assert_observations #' @return An asserted object of `x`. assert_subsampling_pointwise <- function(x) { - checkmate::assert_matrix(x, - any.missing = FALSE, - ncols = 8) - checkmate::assert_names(colnames(x), identical.to = c("elpd_loo", "mcse_elpd_loo", "p_loo", "looic", "influence_pareto_k", "idx", "m_i", "elpd_loo_approx")) + checkmate::assert_matrix(x, any.missing = FALSE, ncols = 8) + checkmate::assert_names( + colnames(x), + identical.to = c( + "elpd_loo", + "mcse_elpd_loo", + "p_loo", + "looic", + "influence_pareto_k", + "idx", + "m_i", + "elpd_loo_approx" + ) + ) x } diff --git a/R/pointwise.R b/R/pointwise.R index 36556464..b8bc6835 100644 --- a/R/pointwise.R +++ b/R/pointwise.R @@ -31,9 +31,11 @@ pointwise.loo <- function(x, estimate, ...) { estimates <- colnames(pw) if (!(estimate %in% estimates)) { stop( - "'", estimate, "' not found.", + "'", + estimate, + "' not found.", " Available estimates are: \n", - paste(shQuote(estimates), collapse=", ") + paste(shQuote(estimates), collapse = ", ") ) } pw[, estimate] diff --git a/R/print.R b/R/print.R index f05834d6..4df8740b 100644 --- a/R/print.R +++ b/R/print.R @@ -142,7 +142,9 @@ print_dims.importance_sampling_loo <- function(x, ...) { cat( "Computed from", paste(dim(x), collapse = " by "), - "log-likelihood matrix using", class(x)[1], ".\n" + "log-likelihood matrix using", + class(x)[1], + ".\n" ) } @@ -170,7 +172,7 @@ print_dims.kfold <- function(x, ...) { print_dims.psis_loo_ss <- function(x, ...) { cat( "Computed from", - paste(c(dim(x)[1], nobs(x)) , collapse = " by "), + paste(c(dim(x)[1], nobs(x)), collapse = " by "), "subsampled log-likelihood\nvalues from", length(x$loo_subsampling$elpd_loo_approx), "total observations.\n" @@ -181,13 +183,13 @@ print_reff_summary <- function(x, digits) { r_eff <- x$diagnostics$r_eff if (is.null(r_eff)) { if (!is.null(x$psis_object)) { - r_eff <- attr(x$psis_object,'r_eff') + r_eff <- attr(x$psis_object, 'r_eff') } else { - r_eff <- attr(x,'r_eff') + r_eff <- attr(x, 'r_eff') } } if (!is.null(r_eff)) { - if (all(r_eff==1)) { + if (all(r_eff == 1)) { cat( "MCSE and ESS estimates assume independent draws (r_eff=1).\n" ) diff --git a/R/psis.R b/R/psis.R index 1b321d70..420d69d6 100644 --- a/R/psis.R +++ b/R/psis.R @@ -98,13 +98,14 @@ psis <- function(log_ratios, ...) UseMethod("psis") #' @template array #' psis.array <- - function(log_ratios, ..., - r_eff = 1, - cores = getOption("mc.cores", 1)) { - importance_sampling.array(log_ratios = log_ratios, ..., - r_eff = r_eff, - cores = cores, - method = "psis") + function(log_ratios, ..., r_eff = 1, cores = getOption("mc.cores", 1)) { + importance_sampling.array( + log_ratios = log_ratios, + ..., + r_eff = r_eff, + cores = cores, + method = "psis" + ) } @@ -113,15 +114,14 @@ psis.array <- #' @template matrix #' psis.matrix <- - function(log_ratios, - ..., - r_eff = 1, - cores = getOption("mc.cores", 1)) { - importance_sampling.matrix(log_ratios, - ..., - r_eff = r_eff, - cores = cores, - method = "psis") + function(log_ratios, ..., r_eff = 1, cores = getOption("mc.cores", 1)) { + importance_sampling.matrix( + log_ratios, + ..., + r_eff = r_eff, + cores = cores, + method = "psis" + ) } #' @export @@ -130,9 +130,12 @@ psis.matrix <- #' psis.default <- function(log_ratios, ..., r_eff = 1) { - importance_sampling.default(log_ratios = log_ratios, ..., - r_eff = r_eff, - method = "psis") + importance_sampling.default( + log_ratios = log_ratios, + ..., + r_eff = r_eff, + method = "psis" + ) } @@ -149,25 +152,26 @@ is.psis <- function(x) { #' @noRd #' @seealso importance_sampling_object psis_object <- - function(unnormalized_log_weights, - pareto_k, - tail_len, - r_eff) { - importance_sampling_object(unnormalized_log_weights = unnormalized_log_weights, - pareto_k = pareto_k, - tail_len = tail_len, - r_eff = r_eff, - method = "psis") + function(unnormalized_log_weights, pareto_k, tail_len, r_eff) { + importance_sampling_object( + unnormalized_log_weights = unnormalized_log_weights, + pareto_k = pareto_k, + tail_len = tail_len, + r_eff = r_eff, + method = "psis" + ) } #' @noRd #' @seealso do_importance_sampling -do_psis <- function(log_ratios, r_eff, cores, method){ - do_importance_sampling(log_ratios = log_ratios, - r_eff = r_eff, - cores = cores, - method = "psis") +do_psis <- function(log_ratios, r_eff, cores, method) { + do_importance_sampling( + log_ratios = log_ratios, + r_eff = r_eff, + cores = cores, + method = "psis" + ) } #' Extract named components from each list in the list of lists obtained by @@ -181,7 +185,9 @@ do_psis <- function(log_ratios, r_eff, cores, method){ #' @return Numeric vector or matrix. #' psis_apply <- function(x, item, fun = c("[[", "attr"), fun_val = numeric(1)) { - if (!is.list(x)) stop("Internal error ('x' must be a list for psis_apply)") + if (!is.list(x)) { + stop("Internal error ('x' must be a list for psis_apply)") + } vapply(x, FUN = match.arg(fun), FUN.VALUE = fun_val, item) } @@ -212,7 +218,7 @@ do_psis_i <- function(log_ratios_i, tail_len_i, ...) { ord <- sort.int(lw_i, index.return = TRUE) tail_ids <- seq(S - tail_len_i + 1, S) lw_tail <- ord$x[tail_ids] - if (abs(max(lw_tail) - min(lw_tail)) < .Machine$double.eps/100) { + if (abs(max(lw_tail) - min(lw_tail)) < .Machine$double.eps / 100) { warning( "Can't fit generalized Pareto distribution ", "because all tail values are the same.", @@ -252,11 +258,11 @@ psis_smooth_tail <- function(x, cutoff) { k <- fit$k sigma <- fit$sigma if (is.finite(k)) { - p <- (seq_len(len) - 0.5) / len - qq <- qgpd(p, k, sigma) + exp_cutoff - tail <- log(qq) + p <- (seq_len(len) - 0.5) / len + qq <- qgpd(p, k, sigma) + exp_cutoff + tail <- log(qq) } else { - tail <- x + tail <- x } list(tail = tail, k = k) } @@ -322,7 +328,8 @@ throw_tail_length_warnings <- function(tail_lengths) { if (length(tail_lengths) == 1) { warning( "Not enough tail samples to fit the generalized Pareto distribution.", - call. = FALSE, immediate. = TRUE + call. = FALSE, + immediate. = TRUE ) } else { bad <- which(tail_len_bad) @@ -332,7 +339,11 @@ throw_tail_length_warnings <- function(tail_lengths) { "in some or all columns of matrix of log importance ratios. ", "Skipping the following columns: ", paste(if (Nbad <= 10) bad else bad[1:10], collapse = ", "), - if (Nbad > 10) paste0(", ... [", Nbad - 10, " more not printed].\n") else "\n", + if (Nbad > 10) { + paste0(", ... [", Nbad - 10, " more not printed].\n") + } else { + "\n" + }, call. = FALSE, immediate. = TRUE ) @@ -360,7 +371,10 @@ prepare_psis_r_eff <- function(r_eff, len) { } else if (length(r_eff) == 1) { r_eff <- rep(r_eff, len) } else if (length(r_eff) != len) { - stop("'r_eff' must have one value or one value per observation.", call. = FALSE) + stop( + "'r_eff' must have one value or one value per observation.", + call. = FALSE + ) } else if (anyNA(r_eff)) { stop("Can't mix NA and not NA values in 'r_eff'.", call. = FALSE) } @@ -390,4 +404,3 @@ throw_psis_r_eff_warning <- function() { call. = FALSE ) } - diff --git a/R/psis_approximate_posterior.R b/R/psis_approximate_posterior.R index ebd9b4a4..d9a27086 100644 --- a/R/psis_approximate_posterior.R +++ b/R/psis_approximate_posterior.R @@ -21,14 +21,33 @@ #' #' @keywords internal #' -psis_approximate_posterior <- function(log_p = NULL, log_g = NULL, log_liks = NULL, - cores, save_psis, ..., log_q = NULL) { +psis_approximate_posterior <- function( + log_p = NULL, + log_g = NULL, + log_liks = NULL, + cores, + save_psis, + ..., + log_q = NULL +) { if (!is.null(log_q)) { - .Deprecated(msg = "psis_approximate_posterior() argument log_q has been changed to log_g") + .Deprecated( + msg = "psis_approximate_posterior() argument log_q has been changed to log_g" + ) log_g <- log_q } - checkmate::assert_numeric(log_p, any.missing = FALSE, len = length(log_g), null.ok = FALSE) - checkmate::assert_numeric(log_g, any.missing = FALSE, len = length(log_p), null.ok = FALSE) + checkmate::assert_numeric( + log_p, + any.missing = FALSE, + len = length(log_g), + null.ok = FALSE + ) + checkmate::assert_numeric( + log_g, + any.missing = FALSE, + len = length(log_p), + null.ok = FALSE + ) checkmate::assert_matrix(log_liks, null.ok = TRUE, nrows = length(log_p)) checkmate::assert_integerish(cores) checkmate::assert_flag(save_psis) @@ -39,9 +58,17 @@ psis_approximate_posterior <- function(log_p = NULL, log_g = NULL, log_liks = NU approx_correction <- approx_correction - max(approx_correction) log_ratios <- matrix(approx_correction, ncol = 1) } else { - log_ratios <- correct_log_ratios(log_ratios = -log_liks, log_p = log_p, log_g = log_g) + log_ratios <- correct_log_ratios( + log_ratios = -log_liks, + log_p = log_p, + log_g = log_g + ) } - psis_out <- psis.matrix(log_ratios, cores = cores, r_eff = rep(1, ncol(log_ratios))) + psis_out <- psis.matrix( + log_ratios, + cores = cores, + r_eff = rep(1, ncol(log_ratios)) + ) if (is.null(log_liks)) { return(psis_out) @@ -58,7 +85,6 @@ psis_approximate_posterior <- function(log_p = NULL, log_g = NULL, log_liks = NU } - #' Correct log ratios for posterior approximations #' #' @inheritParams psis_approximate_posterior @@ -90,46 +116,49 @@ ap_psis <- function(log_ratios, log_p, log_g, ...) { #' @template array #' ap_psis.array <- - function(log_ratios, log_p, log_g, ..., - cores = getOption("mc.cores", 1)) { + function(log_ratios, log_p, log_g, ..., cores = getOption("mc.cores", 1)) { cores <- loo_cores(cores) stopifnot(length(dim(log_ratios)) == 3) log_ratios <- validate_ll(log_ratios) log_ratios <- llarray_to_matrix(log_ratios) r_eff <- prepare_psis_r_eff(r_eff, len = ncol(log_ratios)) - ap_psis.matrix(log_ratios = log_ratios, - log_p = log_p, - log_g = log_g, - cores = 1) + ap_psis.matrix( + log_ratios = log_ratios, + log_p = log_p, + log_g = log_g, + cores = 1 + ) } #' @export #' @templateVar fn ap_psis #' @template matrix #' -ap_psis.matrix <- function(log_ratios, log_p, log_g, - ..., - cores = getOption("mc.cores", 1)) { - checkmate::assert_numeric(log_p, len = nrow(log_ratios)) - checkmate::assert_numeric(log_g, len = nrow(log_ratios)) - cores <- loo_cores(cores) - log_ratios <- validate_ll(log_ratios) - - log_ratios <- correct_log_ratios(log_ratios, log_p = log_p, log_g = log_g) - - do_psis(log_ratios, r_eff = rep(1, ncol(log_ratios)), cores = cores) - } +ap_psis.matrix <- function( + log_ratios, + log_p, + log_g, + ..., + cores = getOption("mc.cores", 1) +) { + checkmate::assert_numeric(log_p, len = nrow(log_ratios)) + checkmate::assert_numeric(log_g, len = nrow(log_ratios)) + cores <- loo_cores(cores) + log_ratios <- validate_ll(log_ratios) + + log_ratios <- correct_log_ratios(log_ratios, log_p = log_p, log_g = log_g) + + do_psis(log_ratios, r_eff = rep(1, ncol(log_ratios)), cores = cores) +} #' @export #' @templateVar fn ap_psis #' @template vector #' ap_psis.default <- function(log_ratios, log_p, log_g, ...) { - stopifnot(is.null(dim(log_ratios)) || length(dim(log_ratios)) == 1) - dim(log_ratios) <- c(length(log_ratios), 1) - warning("llfun values do not return a matrix, coerce to matrix") - ap_psis.matrix(as.matrix(log_ratios), log_p, log_g, cores = 1) - } - - + stopifnot(is.null(dim(log_ratios)) || length(dim(log_ratios)) == 1) + dim(log_ratios) <- c(length(log_ratios), 1) + warning("llfun values do not return a matrix, coerce to matrix") + ap_psis.matrix(as.matrix(log_ratios), log_p, log_g, cores = 1) +} diff --git a/R/psislw.R b/R/psislw.R index 9ed5ab15..ac0694f9 100644 --- a/R/psislw.R +++ b/R/psislw.R @@ -34,10 +34,15 @@ #' #' @importFrom parallel mclapply makePSOCKcluster stopCluster parLapply #' -psislw <- function(lw, wcp = 0.2, wtrunc = 3/4, - cores = getOption("mc.cores", 1), - llfun = NULL, llargs = NULL, - ...) { +psislw <- function( + lw, + wcp = 0.2, + wtrunc = 3 / 4, + cores = getOption("mc.cores", 1), + llfun = NULL, + llargs = NULL, + ... +) { .Deprecated("psis") cores <- loo_cores(cores) @@ -51,18 +56,19 @@ psislw <- function(lw, wcp = 0.2, wtrunc = 3/4, tail_len <- length(x_tail) if (tail_len < MIN_TAIL_LENGTH || all(x_tail == x_tail[1])) { - if (all(x_tail == x_tail[1])) + if (all(x_tail == x_tail[1])) { warning( "All tail values are the same. ", "Weights are truncated but not smoothed.", call. = FALSE ) - else if (tail_len < MIN_TAIL_LENGTH) + } else if (tail_len < MIN_TAIL_LENGTH) { warning( "Too few tail samples to fit generalized Pareto distribution.\n", "Weights are truncated but not smoothed.", call. = FALSE ) + } x_new <- x k <- Inf @@ -72,7 +78,7 @@ psislw <- function(lw, wcp = 0.2, wtrunc = 3/4, # body and gPd smoothed tail tail_ord <- order(x_tail) exp_cutoff <- exp(cutoff) - fit <- gpdfit(exp(x_tail) - exp_cutoff, wip=FALSE, min_grid_pts = 80) + fit <- gpdfit(exp(x_tail) - exp_cutoff, wip = FALSE, min_grid_pts = 80) k <- fit$k sigma <- fit$sigma prb <- (seq_len(tail_len) - 0.5) / tail_len @@ -91,19 +97,22 @@ psislw <- function(lw, wcp = 0.2, wtrunc = 3/4, .psis_loop <- function(i) { if (LL_FUN) { - ll_i <- llfun(i = i, - data = llargs$data[i,, drop=FALSE], - draws = llargs$draws) + ll_i <- llfun( + i = i, + data = llargs$data[i, , drop = FALSE], + draws = llargs$draws + ) lw_i <- -1 * ll_i } else { lw_i <- lw[, i] ll_i <- -1 * lw_i } psis <- .psis(lw_i) - if (FROM_LOO) + if (FROM_LOO) { nlist(lse = logSumExp(ll_i + psis$lw_new), k = psis$k) - else + } else { psis + } } # minimal cutoff value. there must be at least 5 log-weights larger than this @@ -111,17 +120,22 @@ psislw <- function(lw, wcp = 0.2, wtrunc = 3/4, MIN_CUTOFF <- -700 MIN_TAIL_LENGTH <- 5 dots <- list(...) - FROM_LOO <- if ("COMPUTE_LOOS" %in% names(dots)) - dots$COMPUTE_LOOS else FALSE + FROM_LOO <- if ("COMPUTE_LOOS" %in% names(dots)) { + dots$COMPUTE_LOOS + } else { + FALSE + } if (!missing(lw)) { - if (!is.matrix(lw)) + if (!is.matrix(lw)) { lw <- as.matrix(lw) + } N <- ncol(lw) LL_FUN <- FALSE } else { - if (is.null(llfun) || is.null(llargs)) + if (is.null(llfun) || is.null(llargs)) { stop("Either 'lw' or 'llfun' and 'llargs' must be specified.") + } N <- llargs$N LL_FUN <- TRUE } @@ -159,16 +173,18 @@ psislw <- function(lw, wcp = 0.2, wtrunc = 3/4, # internal ---------------------------------------------------------------- lw_cutpoint <- function(y, wcp, min_cut) { - if (min_cut < log(.Machine$double.xmin)) + if (min_cut < log(.Machine$double.xmin)) { min_cut <- -700 + } cp <- quantile(y, 1 - wcp, names = FALSE) max(cp, min_cut) } lw_truncate <- function(y, wtrunc) { - if (wtrunc == 0) + if (wtrunc == 0) { return(y) + } logS <- log(length(y)) lwtrunc <- wtrunc * logS - logS + logSumExp(y) diff --git a/R/sis.R b/R/sis.R index fa64e358..0fee4067 100644 --- a/R/sis.R +++ b/R/sis.R @@ -84,13 +84,14 @@ sis <- function(log_ratios, ...) UseMethod("sis") #' @template array #' sis.array <- - function(log_ratios, ..., - r_eff = NULL, - cores = getOption("mc.cores", 1)) { - importance_sampling.array(log_ratios = log_ratios, ..., - r_eff = r_eff, - cores = cores, - method = "sis") + function(log_ratios, ..., r_eff = NULL, cores = getOption("mc.cores", 1)) { + importance_sampling.array( + log_ratios = log_ratios, + ..., + r_eff = r_eff, + cores = cores, + method = "sis" + ) } #' @export @@ -98,15 +99,14 @@ sis.array <- #' @template matrix #' sis.matrix <- - function(log_ratios, - ..., - r_eff = NULL, - cores = getOption("mc.cores", 1)) { - importance_sampling.matrix(log_ratios, - ..., - r_eff = r_eff, - cores = cores, - method = "sis") + function(log_ratios, ..., r_eff = NULL, cores = getOption("mc.cores", 1)) { + importance_sampling.matrix( + log_ratios, + ..., + r_eff = r_eff, + cores = cores, + method = "sis" + ) } #' @export @@ -115,9 +115,12 @@ sis.matrix <- #' sis.default <- function(log_ratios, ..., r_eff = NULL) { - importance_sampling.default(log_ratios = log_ratios, ..., - r_eff = r_eff, - method = "sis") + importance_sampling.default( + log_ratios = log_ratios, + ..., + r_eff = r_eff, + method = "sis" + ) } #' @rdname psis @@ -129,7 +132,6 @@ is.sis <- function(x) { # internal ---------------------------------------------------------------- - #' Standard IS on a single vector #' #' @noRd diff --git a/R/split_moment_matching.R b/R/split_moment_matching.R index b7bdb111..7ae41258 100644 --- a/R/split_moment_matching.R +++ b/R/split_moment_matching.R @@ -38,10 +38,21 @@ #' @template moment-matching-references #' #' -loo_moment_match_split <- function(x, upars, cov, total_shift, total_scaling, - total_mapping, i, log_prob_upars, - log_lik_i_upars, r_eff_i, cores, - is_method, ...) { +loo_moment_match_split <- function( + x, + upars, + cov, + total_shift, + total_scaling, + total_mapping, + i, + log_prob_upars, + log_lik_i_upars, + r_eff_i, + cores, + is_method, + ... +) { S <- dim(upars)[1] S_half <- as.integer(0.5 * S) mean_original <- colMeans(upars) @@ -78,44 +89,56 @@ loo_moment_match_split <- function(x, upars, cov, total_shift, total_scaling, # compute log likelihoods and log probabilities log_prob_half_trans <- log_prob_upars(x, upars = upars_trans_half, ...) - log_prob_half_trans_inv <- log_prob_upars(x, upars = upars_trans_half_inv, ...) + log_prob_half_trans_inv <- log_prob_upars( + x, + upars = upars_trans_half_inv, + ... + ) log_liki_half <- log_lik_i_upars(x, upars = upars_trans_half, i = i, ...) # compute weights log_prob_half_trans_inv <- (log_prob_half_trans_inv - - log(prod(total_scaling)) - - log(det(total_mapping))) + log(prod(total_scaling)) - + log(det(total_mapping))) stable_S <- log_prob_half_trans > log_prob_half_trans_inv lwi_half <- -log_liki_half + log_prob_half_trans lwi_half[stable_S] <- lwi_half[stable_S] - (log_prob_half_trans[stable_S] + - log1p(exp(log_prob_half_trans_inv[stable_S] - - log_prob_half_trans[stable_S]))) + log1p(exp( + log_prob_half_trans_inv[stable_S] - + log_prob_half_trans[stable_S] + ))) lwi_half[!stable_S] <- lwi_half[!stable_S] - (log_prob_half_trans_inv[!stable_S] + - log1p(exp(log_prob_half_trans[!stable_S] - - log_prob_half_trans_inv[!stable_S]))) + log1p(exp( + log_prob_half_trans[!stable_S] - + log_prob_half_trans_inv[!stable_S] + ))) # lwi_half may have NaNs if computation involves -Inf + Inf # replace NaN log ratios with -Inf lr <- lwi_half lr[is.na(lr)] <- -Inf - is_obj_half <- suppressWarnings(importance_sampling.default(lr, - method = is_method, - r_eff = r_eff_i, - cores = cores)) + is_obj_half <- suppressWarnings(importance_sampling.default( + lr, + method = is_method, + r_eff = r_eff_i, + cores = cores + )) lwi_half <- as.vector(weights(is_obj_half)) # lwi_half may have NaNs if computation involves -Inf + Inf # replace NaN log ratios with -Inf lr <- lwi_half + log_liki_half lr[is.na(lr)] <- -Inf - is_obj_f_half <- suppressWarnings(importance_sampling.default(lr, - method = is_method, - r_eff = r_eff_i, - cores = cores)) + is_obj_f_half <- suppressWarnings(importance_sampling.default( + lr, + method = is_method, + r_eff = r_eff_i, + cores = cores + )) lwfi_half <- as.vector(weights(is_obj_f_half)) # relative_eff recomputation @@ -130,7 +153,7 @@ loo_moment_match_split <- function(x, upars, cov, total_shift, total_scaling, dim(log_liki_half_2) <- c(length(take), 1, 1) r_eff_i1 <- loo::relative_eff(exp(log_liki_half_1), cores = cores) r_eff_i2 <- loo::relative_eff(exp(log_liki_half_2), cores = cores) - r_eff_i <- min(r_eff_i1,r_eff_i2) + r_eff_i <- min(r_eff_i1, r_eff_i2) list( lwi = lwi_half, diff --git a/R/tis.R b/R/tis.R index 39bf166d..d9d0ff04 100644 --- a/R/tis.R +++ b/R/tis.R @@ -89,13 +89,14 @@ tis <- function(log_ratios, ...) UseMethod("tis") #' @template array #' tis.array <- - function(log_ratios, ..., - r_eff = 1, - cores = getOption("mc.cores", 1)) { - importance_sampling.array(log_ratios = log_ratios, ..., - r_eff = r_eff, - cores = cores, - method = "tis") + function(log_ratios, ..., r_eff = 1, cores = getOption("mc.cores", 1)) { + importance_sampling.array( + log_ratios = log_ratios, + ..., + r_eff = r_eff, + cores = cores, + method = "tis" + ) } #' @export @@ -103,15 +104,14 @@ tis.array <- #' @template matrix #' tis.matrix <- - function(log_ratios, - ..., - r_eff = 1, - cores = getOption("mc.cores", 1)) { - importance_sampling.matrix(log_ratios, - ..., - r_eff = r_eff, - cores = cores, - method = "tis") + function(log_ratios, ..., r_eff = 1, cores = getOption("mc.cores", 1)) { + importance_sampling.matrix( + log_ratios, + ..., + r_eff = r_eff, + cores = cores, + method = "tis" + ) } #' @export @@ -120,8 +120,12 @@ tis.matrix <- #' tis.default <- function(log_ratios, ..., r_eff = 1) { - importance_sampling.default(log_ratios = log_ratios, ..., - r_eff = r_eff, method = "tis") + importance_sampling.default( + log_ratios = log_ratios, + ..., + r_eff = r_eff, + method = "tis" + ) } @@ -157,4 +161,3 @@ do_tis_i <- function(log_ratios_i, ...) { lw_i <- pmin(log_ratios_i, log_cutpoint) list(log_weights = lw_i, pareto_k = 0) } - diff --git a/R/waic.R b/R/waic.R index b225ba7e..50d1fabf 100644 --- a/R/waic.R +++ b/R/waic.R @@ -97,17 +97,18 @@ waic.matrix <- function(x, ...) { #' **Methods (by class)** section below for details on these arguments. #' waic.function <- - function(x, - ..., - data = NULL, - draws = NULL) { + function(x, ..., data = NULL, draws = NULL) { stopifnot(is.data.frame(data) || is.matrix(data), !is.null(draws)) .llfun <- validate_llfun(x) N <- dim(data)[1] - S <- length(as.vector(.llfun(data_i = data[1,, drop=FALSE], draws = draws, ...))) + S <- length(as.vector(.llfun( + data_i = data[1, , drop = FALSE], + draws = draws, + ... + ))) waic_list <- lapply(seq_len(N), FUN = function(i) { - ll_i <- .llfun(data_i = data[i,, drop=FALSE], draws = draws, ...) + ll_i <- .llfun(data_i = data[i, , drop = FALSE], draws = draws, ...) ll_i <- as.vector(ll_i) lpd_i <- logMeanExp(ll_i) p_waic_i <- var(ll_i) @@ -141,7 +142,14 @@ waic_object <- function(pointwise, dims) { estimates <- table_of_estimates(pointwise) out <- nlist(estimates, pointwise) # maintain backwards compatibility - old_nms <- c("elpd_waic", "p_waic", "waic", "se_elpd_waic", "se_p_waic", "se_waic") + old_nms <- c( + "elpd_waic", + "p_waic", + "waic", + "se_elpd_waic", + "se_p_waic", + "se_waic" + ) out <- c(out, setNames(as.list(estimates), old_nms)) structure( out, @@ -157,11 +165,15 @@ throw_pwaic_warnings <- function(p, digits = 1, warn = TRUE) { if (any(badp)) { count <- sum(badp) prop <- count / length(badp) - msg <- paste0("\n", count, " (", .fr(100 * prop, digits), - "%) p_waic estimates greater than 0.4. ", - "We recommend trying loo instead.") + msg <- paste0( + "\n", + count, + " (", + .fr(100 * prop, digits), + "%) p_waic estimates greater than 0.4. ", + "We recommend trying loo instead." + ) if (warn) .warn(msg) else cat(msg, "\n") } invisible(NULL) } - diff --git a/R/zzz.R b/R/zzz.R index 87dc9e20..87f1fda6 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -17,7 +17,3 @@ ) } } - - - - diff --git a/air.toml b/air.toml new file mode 100644 index 00000000..e69de29b diff --git a/data-raw/generate-example_loglik_array.R b/data-raw/generate-example_loglik_array.R index 3e12eb6c..2d8a365d 100644 --- a/data-raw/generate-example_loglik_array.R +++ b/data-raw/generate-example_loglik_array.R @@ -3,5 +3,8 @@ library(rstanarm) fit <- stan_glm(mpg ~ wt, data = mtcars, chains = 2, iter = 1000, warmup = 500) ll <- log_lik(fit) -.example_loglik_array <- loo:::llmatrix_to_array(ll, chain_id = rep(1:2, each = 500)) +.example_loglik_array <- loo:::llmatrix_to_array( + ll, + chain_id = rep(1:2, each = 500) +) devtools::use_data(.example_loglik_array, internal = TRUE, overwrite = TRUE) diff --git a/data-raw/generate-example_posterior_approximation.R b/data-raw/generate-example_posterior_approximation.R index f687b3ad..a99fbb4a 100644 --- a/data-raw/generate-example_posterior_approximation.R +++ b/data-raw/generate-example_posterior_approximation.R @@ -13,13 +13,28 @@ #' @param seed The numeric seed to use for simulation #' #' @export -generate_lr_data <- function(D = 10, N = 1000, off_diag_cov = 0.7, seed = 4711, scaled = FALSE, sigma_noise = 0.01, round.digits = 7){ +generate_lr_data <- function( + D = 10, + N = 1000, + off_diag_cov = 0.7, + seed = 4711, + scaled = FALSE, + sigma_noise = 0.01, + round.digits = 7 +) { set.seed(seed) - x <- mvtnorm::rmvnorm(n = N, mean = rep(0, D), sigma = solve(diag(D) + off_diag_cov - diag(D)*off_diag_cov)/N) - if (scaled) x <- scale(x); attr(x,"scaled:scale") <- attr(x,"scaled:center") <- NULL + x <- mvtnorm::rmvnorm( + n = N, + mean = rep(0, D), + sigma = solve(diag(D) + off_diag_cov - diag(D) * off_diag_cov) / N + ) + if (scaled) { + x <- scale(x) + } + attr(x, "scaled:scale") <- attr(x, "scaled:center") <- NULL x <- round(x, digits = round.digits) b <- as.matrix(rep(1.0, D)) - y <- as.vector(x%*%b + rnorm(N, sd = sigma_noise)) + y <- as.vector(x %*% b + rnorm(N, sd = sigma_noise)) y <- round(y, digits = round.digits) list(x = x, D = D, N = N, y = y) } @@ -35,7 +50,7 @@ generate_lr_data <- function(D = 10, N = 1000, off_diag_cov = 0.7, seed = 4711, #' @param par_unconstrained is the sigma on unconstrained space? #' #' @export -log_lik_blinreg <- function(b, x, y, sigma, par_unconstrained = FALSE){ +log_lik_blinreg <- function(b, x, y, sigma, par_unconstrained = FALSE) { checkmate::assert_class(b, classes = "matrix") checkmate::assert_class(x, classes = "matrix") checkmate::assert_numeric(y, len = nrow(x)) @@ -44,11 +59,13 @@ log_lik_blinreg <- function(b, x, y, sigma, par_unconstrained = FALSE){ bx <- b %*% t(x) log_lik <- matrix(0, nrow = nrow(b), ncol = nrow(x)) - if (par_unconstrained) sigma <- exp(sigma) - for(s in 1:nrow(b)){ - for(i in 1:nrow(x)){ - log_lik[s,i] <- - dnorm(x = y[i], mean = bx[s,i], sd = sigma[s], log = TRUE) + if (par_unconstrained) { + sigma <- exp(sigma) + } + for (s in 1:nrow(b)) { + for (i in 1:nrow(x)) { + log_lik[s, i] <- + dnorm(x = y[i], mean = bx[s, i], sd = sigma[s], log = TRUE) } } colnames(log_lik) <- paste0("log_lik.", 1:nrow(x)) @@ -57,8 +74,22 @@ log_lik_blinreg <- function(b, x, y, sigma, par_unconstrained = FALSE){ # Generate datasets ---- -lm_cor_post <- generate_lr_data(D = 10, N = 1000, scaled = TRUE, sigma_noise = 1, off_diag_cov = 0.7, seed = 4711) -lm_indep_post <- generate_lr_data(D = 10, N = 1000, scaled = TRUE, sigma_noise = 1, off_diag_cov = 0, seed = 4712) +lm_cor_post <- generate_lr_data( + D = 10, + N = 1000, + scaled = TRUE, + sigma_noise = 1, + off_diag_cov = 0.7, + seed = 4711 +) +lm_indep_post <- generate_lr_data( + D = 10, + N = 1000, + scaled = TRUE, + sigma_noise = 1, + off_diag_cov = 0, + seed = 4712 +) # Generate datasets ---- @@ -90,29 +121,93 @@ log_lik[n] = normal_lpdf(y[n] | x[n,] * b, sigma); stm <- stan_model(model_code = stan_lm) # Laplace test data -opt_independent <- rstan::optimizing(stm, data = lm_indep_post, draws = 5000, constrained = FALSE, hessian = TRUE, seed = 4711) -opt_correlated <- rstan::optimizing(stm, data = lm_indep_post, draws = 5000, constrained = FALSE, hessian = TRUE, seed = 4711) +opt_independent <- rstan::optimizing( + stm, + data = lm_indep_post, + draws = 5000, + constrained = FALSE, + hessian = TRUE, + seed = 4711 +) +opt_correlated <- rstan::optimizing( + stm, + data = lm_indep_post, + draws = 5000, + constrained = FALSE, + hessian = TRUE, + seed = 4711 +) npar_independent <- ncol(opt_independent$theta_tilde) npar_correlated <- ncol(opt_correlated$theta_tilde) -b_independent <- as.matrix(opt_independent$theta_tilde[,1:(npar_independent-1)]) -b_correlated <- as.matrix(opt_correlated$theta_tilde[,1:(npar_correlated-1)]) -sigma_independent <- opt_independent$theta_tilde[,npar_independent] -sigma_correlated <- opt_correlated$theta_tilde[,npar_correlated] -ll_independent <- log_lik_blinreg(b = b_independent, x = lm_indep_post$x, y = lm_indep_post$y, sigma = sigma_independent, par_unconstrained = TRUE) -ll_correlated <- log_lik_blinreg(b = b_correlated, x = lm_cor_post$x, y = lm_cor_post$y, sigma = sigma_correlated, par_unconstrained = TRUE) +b_independent <- as.matrix(opt_independent$theta_tilde[, + 1:(npar_independent - 1) +]) +b_correlated <- as.matrix(opt_correlated$theta_tilde[, 1:(npar_correlated - 1)]) +sigma_independent <- opt_independent$theta_tilde[, npar_independent] +sigma_correlated <- opt_correlated$theta_tilde[, npar_correlated] +ll_independent <- log_lik_blinreg( + b = b_independent, + x = lm_indep_post$x, + y = lm_indep_post$y, + sigma = sigma_independent, + par_unconstrained = TRUE +) +ll_correlated <- log_lik_blinreg( + b = b_correlated, + x = lm_cor_post$x, + y = lm_cor_post$y, + sigma = sigma_correlated, + par_unconstrained = TRUE +) # ADVI test data # The ADVI was run using Yuling Yaos code to get both log_p and log_q. # When this is included in Stan this code should be possible to run from R directly -advi_fullrank_correlated <- read.table("data-raw/raw_data/output_lr_loo_fullrank_grad100_lr.cor.data1k.R.csv", header = TRUE, sep = ",", fill = TRUE) -advi_fullrank_independent <- read.table("data-raw/raw_data/output_lr_loo_fullrank_grad100_lr.nocor.data1k.R.csv", header = TRUE, sep = ",", fill = TRUE) -advi_fullrank_normal <- read.table("data-raw/raw_data/output_normal_model_fullrank_grad100_normal_data.R.csv", header = TRUE, sep = ",", fill = TRUE) -advi_meanfield_correlated <- read.table("data-raw/raw_data/output_lr_loo_meanfield_grad100_lr.cor.data1k.R.csv", header = TRUE, sep = ",", fill = TRUE) -advi_meanfield_independent <- read.table("data-raw/raw_data/output_lr_loo_meanfield_grad100_lr.nocor.data1k.R.csv", header = TRUE, sep = ",", fill = TRUE) -advi_meanfield_normal <- read.table("data-raw/raw_data/output_normal_model_fullrank_grad100_normal_data.R.csv", header = TRUE, sep = ",", fill = TRUE) -log_lik_idx <- which(grepl(colnames(advi_meanfield_independent), pattern = "log_lik")) -log_lik_idx_normal <- which(grepl(colnames(advi_meanfield_normal), pattern = "log_lik")) +advi_fullrank_correlated <- read.table( + "data-raw/raw_data/output_lr_loo_fullrank_grad100_lr.cor.data1k.R.csv", + header = TRUE, + sep = ",", + fill = TRUE +) +advi_fullrank_independent <- read.table( + "data-raw/raw_data/output_lr_loo_fullrank_grad100_lr.nocor.data1k.R.csv", + header = TRUE, + sep = ",", + fill = TRUE +) +advi_fullrank_normal <- read.table( + "data-raw/raw_data/output_normal_model_fullrank_grad100_normal_data.R.csv", + header = TRUE, + sep = ",", + fill = TRUE +) +advi_meanfield_correlated <- read.table( + "data-raw/raw_data/output_lr_loo_meanfield_grad100_lr.cor.data1k.R.csv", + header = TRUE, + sep = ",", + fill = TRUE +) +advi_meanfield_independent <- read.table( + "data-raw/raw_data/output_lr_loo_meanfield_grad100_lr.nocor.data1k.R.csv", + header = TRUE, + sep = ",", + fill = TRUE +) +advi_meanfield_normal <- read.table( + "data-raw/raw_data/output_normal_model_fullrank_grad100_normal_data.R.csv", + header = TRUE, + sep = ",", + fill = TRUE +) +log_lik_idx <- which(grepl( + colnames(advi_meanfield_independent), + pattern = "log_lik" +)) +log_lik_idx_normal <- which(grepl( + colnames(advi_meanfield_normal), + pattern = "log_lik" +)) stan_normal <- " data { @@ -139,14 +234,26 @@ log_lik[n] = normal_lpdf(y[n] | mu , sigma); " stnm <- stan_model(model_code = stan_normal) -stan_normal_data <- list(N = 3, y = c(-15,0,15)) -opt_normal <- rstan::optimizing(stnm, data = stan_normal_data, draws = 1000, constrained = FALSE, hessian = TRUE, seed = 4712) +stan_normal_data <- list(N = 3, y = c(-15, 0, 15)) +opt_normal <- rstan::optimizing( + stnm, + data = stan_normal_data, + draws = 1000, + constrained = FALSE, + hessian = TRUE, + seed = 4712 +) # s_normal <- rstan::sampling(stnm, data = stan_normal_data) log_lik <- matrix(0, nrow = 1000, ncol = stan_normal_data$N) -for(i in 1:ncol(log_lik)){ - log_lik[,i] <- - dnorm(x = stan_normal_data$y[i], mean = opt_normal$theta_tilde[, "mu"], sd = opt_normal$theta_tilde[, "sigma"], log = TRUE) +for (i in 1:ncol(log_lik)) { + log_lik[, i] <- + dnorm( + x = stan_normal_data$y[i], + mean = opt_normal$theta_tilde[, "mu"], + sd = opt_normal$theta_tilde[, "sigma"], + log = TRUE + ) } # hist(opt_normal$theta_tilde[, "sigma"]) @@ -156,36 +263,61 @@ for(i in 1:ncol(log_lik)){ # hist(log_lik[,1]) # hist(extract(s_normal, "log_lik")$log_lik[,1]) - # Create test data list # We only keep 1000 samples and compute likelihoods for 10 observations to minimize memory burden. test_data_psis_approximate_posterior <- - list(laplace_independent = list(log_p = opt_independent$log_p[1:1000], - log_q = opt_independent$log_g[1:1000], - log_liks = ll_independent[1:1000,1:10]), - laplace_correlated = list(log_p = opt_correlated$log_p[1:1000], - log_q = opt_correlated$log_g[1:1000], - log_liks = ll_correlated[1:1000,1:10]), - laplace_normal = list(log_p = opt_normal$log_p[1:1000], - log_q = opt_normal$log_g[1:1000], - log_liks = log_lik[1:1000,]), - meanfield_independent = list(log_p = advi_meanfield_independent$log_p[2:1001], - log_q = advi_meanfield_independent$log_q[2:1001], - log_liks = as.matrix(advi_meanfield_independent[2:1001, log_lik_idx[1:10]])), - meanfield_correlated = list(log_p = advi_meanfield_correlated$log_p[2:1001], - log_q = advi_meanfield_correlated$log_q[2:1001], - log_liks = as.matrix(advi_meanfield_correlated[2:1001, log_lik_idx[1:10]])), - meanfield_normal = list(log_p = advi_meanfield_normal$log_p[2:1001], - log_q = advi_meanfield_normal$log_q[2:1001], - log_liks = as.matrix(advi_meanfield_normal[2:1001, log_lik_idx_normal])), - fullrank_independent = list(log_p = advi_fullrank_independent$log_p[2:1001], - log_q = advi_fullrank_independent$log_q[2:1001], - log_liks = as.matrix(advi_fullrank_independent[2:1001, log_lik_idx[1:10]])), - fullrank_correlated = list(log_p = advi_fullrank_correlated$log_p[2:1001], - log_q = advi_fullrank_correlated$log_q[2:1001], - log_liks = as.matrix(advi_fullrank_correlated[2:1001, log_lik_idx[1:10]])), - fullrank_normal = list(log_p = advi_fullrank_normal$log_p[2:1001], - log_q = advi_fullrank_normal$log_q[2:1001], - log_liks = as.matrix(advi_fullrank_normal[2:1001, log_lik_idx_normal]))) - -save(test_data_psis_approximate_posterior, file = "tests/testthat/data-for-tests/test_data_psis_approximate_posterior.rda") + list( + laplace_independent = list( + log_p = opt_independent$log_p[1:1000], + log_q = opt_independent$log_g[1:1000], + log_liks = ll_independent[1:1000, 1:10] + ), + laplace_correlated = list( + log_p = opt_correlated$log_p[1:1000], + log_q = opt_correlated$log_g[1:1000], + log_liks = ll_correlated[1:1000, 1:10] + ), + laplace_normal = list( + log_p = opt_normal$log_p[1:1000], + log_q = opt_normal$log_g[1:1000], + log_liks = log_lik[1:1000, ] + ), + meanfield_independent = list( + log_p = advi_meanfield_independent$log_p[2:1001], + log_q = advi_meanfield_independent$log_q[2:1001], + log_liks = as.matrix(advi_meanfield_independent[ + 2:1001, + log_lik_idx[1:10] + ]) + ), + meanfield_correlated = list( + log_p = advi_meanfield_correlated$log_p[2:1001], + log_q = advi_meanfield_correlated$log_q[2:1001], + log_liks = as.matrix(advi_meanfield_correlated[2:1001, log_lik_idx[1:10]]) + ), + meanfield_normal = list( + log_p = advi_meanfield_normal$log_p[2:1001], + log_q = advi_meanfield_normal$log_q[2:1001], + log_liks = as.matrix(advi_meanfield_normal[2:1001, log_lik_idx_normal]) + ), + fullrank_independent = list( + log_p = advi_fullrank_independent$log_p[2:1001], + log_q = advi_fullrank_independent$log_q[2:1001], + log_liks = as.matrix(advi_fullrank_independent[2:1001, log_lik_idx[1:10]]) + ), + fullrank_correlated = list( + log_p = advi_fullrank_correlated$log_p[2:1001], + log_q = advi_fullrank_correlated$log_q[2:1001], + log_liks = as.matrix(advi_fullrank_correlated[2:1001, log_lik_idx[1:10]]) + ), + fullrank_normal = list( + log_p = advi_fullrank_normal$log_p[2:1001], + log_q = advi_fullrank_normal$log_q[2:1001], + log_liks = as.matrix(advi_fullrank_normal[2:1001, log_lik_idx_normal]) + ) + ) + +save( + test_data_psis_approximate_posterior, + file = "tests/testthat/data-for-tests/test_data_psis_approximate_posterior.rda" +) diff --git a/man-roxygen/loo-and-compare-references.R b/man-roxygen/loo-and-compare-references.R index 9c8bd866..15aab96e 100644 --- a/man-roxygen/loo-and-compare-references.R +++ b/man-roxygen/loo-and-compare-references.R @@ -13,7 +13,7 @@ #' Sivula, T, Magnusson, M., Matamoros A. A., and Vehtari, A. (2022). #' Uncertainty in Bayesian leave-one-out cross-validation based model #' comparison. [preprint arXiv:2008.10296v3.](https://arxiv.org/abs/2008.10296v3). -#' +#' #' McLatchie, Y., and Vehtari, A. (2023). Efficient estimation and #' correction of selection-induced bias with order statistics. #' [preprint arXiv:2309.03742](https://arxiv.org/abs/2309.03742) diff --git a/tests/testthat/data-for-tests/function_method_stuff.R b/tests/testthat/data-for-tests/function_method_stuff.R index 2e57b9e2..fcd97a2d 100644 --- a/tests/testthat/data-for-tests/function_method_stuff.R +++ b/tests/testthat/data-for-tests/function_method_stuff.R @@ -1,10 +1,15 @@ -N <- 50; K <- 10; S <- 100; a0 <- 3; b0 <- 2 +N <- 50 +K <- 10 +S <- 100 +a0 <- 3 +b0 <- 2 p <- rbeta(1, a0, b0) y <- rbinom(N, size = K, prob = p) -a <- a0 + sum(y); b <- b0 + N * K - sum(y) +a <- a0 + sum(y) +b <- b0 + N * K - sum(y) draws <- as.matrix(rbeta(S, a, b)) -data <- data.frame(y,K) +data <- data.frame(y, K) llfun <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } -llmat_from_fn <- sapply(1:N, function(i) llfun(data[i,, drop=FALSE], draws)) +llmat_from_fn <- sapply(1:N, function(i) llfun(data[i, , drop = FALSE], draws)) diff --git a/tests/testthat/test_0_helpers.R b/tests/testthat/test_0_helpers.R index 09bfb06a..51fe3057 100644 --- a/tests/testthat/test_0_helpers.R +++ b/tests/testthat/test_0_helpers.R @@ -25,18 +25,26 @@ test_that("reshaping functions result in correct dimensions", { }) test_that("reshaping functions throw correct errors", { - expect_error(llmatrix_to_array(LLmat, chain_id = rep(1:2, times = c(400, 600))), - regexp = "Not all chains have same number of iterations", - fixed = TRUE) - expect_error(llmatrix_to_array(LLmat, chain_id = rep(1:2, each = 400)), - regexp = "Number of rows in matrix not equal to length(chain_id)", - fixed = TRUE) - expect_error(llmatrix_to_array(LLmat, chain_id = rep(2:3, each = 500)), - regexp = "max(chain_id) not equal to the number of chains", - fixed = TRUE) - expect_error(llmatrix_to_array(LLmat, chain_id = rnorm(1000)), - regexp = "all(chain_id == as.integer(chain_id)) is not TRUE", - fixed = TRUE) + expect_error( + llmatrix_to_array(LLmat, chain_id = rep(1:2, times = c(400, 600))), + regexp = "Not all chains have same number of iterations", + fixed = TRUE + ) + expect_error( + llmatrix_to_array(LLmat, chain_id = rep(1:2, each = 400)), + regexp = "Number of rows in matrix not equal to length(chain_id)", + fixed = TRUE + ) + expect_error( + llmatrix_to_array(LLmat, chain_id = rep(2:3, each = 500)), + regexp = "max(chain_id) not equal to the number of chains", + fixed = TRUE + ) + expect_error( + llmatrix_to_array(LLmat, chain_id = rnorm(1000)), + regexp = "all(chain_id == as.integer(chain_id)) is not TRUE", + fixed = TRUE + ) }) test_that("colLogMeanExps(x) = log(colMeans(exp(x))) ", { @@ -55,9 +63,14 @@ test_that("validating log-lik objects and functions works", { }) test_that("nlist works", { - a <- 1; b <- 2; c <- 3; + a <- 1 + b <- 2 + c <- 3 nlist_val <- list(nlist(a, b, c), nlist(a, b, c = "tornado")) - nlist_ans <- list(list(a = 1, b = 2, c = 3), list(a = 1, b = 2, c = "tornado")) + nlist_ans <- list( + list(a = 1, b = 2, c = 3), + list(a = 1, b = 2, c = "tornado") + ) expect_equal(nlist_val, nlist_ans) expect_equal(nlist(a = 1, b = 2, c = 3), list(a = 1, b = 2, c = 3)) }) @@ -70,6 +83,5 @@ test_that("loo_cores works", { options(loo.cores = 2) expect_warning(expect_equal(loo_cores(10), 2), "deprecated") - options(loo.cores=NULL) + options(loo.cores = NULL) }) - diff --git a/tests/testthat/test_E_loo.R b/tests/testthat/test_E_loo.R index 940fb929..558142a9 100644 --- a/tests/testthat/test_E_loo.R +++ b/tests/testthat/test_E_loo.R @@ -19,15 +19,54 @@ log_rats <- -LLmat E_test_mean <- E_loo(x, psis_mat, type = "mean", log_ratios = log_rats) E_test_var <- E_loo(x, psis_mat, type = "var", log_ratios = log_rats) E_test_sd <- E_loo(x, psis_mat, type = "sd", log_ratios = log_rats) -E_test_quant <- E_loo(x, psis_mat, type = "quantile", probs = 0.5, log_ratios = log_rats) -E_test_quant2 <- E_loo(x, psis_mat, type = "quantile", probs = c(0.1, 0.9), log_ratios = log_rats) +E_test_quant <- E_loo( + x, + psis_mat, + type = "quantile", + probs = 0.5, + log_ratios = log_rats +) +E_test_quant2 <- E_loo( + x, + psis_mat, + type = "quantile", + probs = c(0.1, 0.9), + log_ratios = log_rats +) # vector method -E_test_mean_vec <- E_loo(x[, 1], psis_vec, type = "mean", log_ratios = log_rats[,1]) -E_test_var_vec <- E_loo(x[, 1], psis_vec, type = "var", log_ratios = log_rats[,1]) -E_test_sd_vec <- E_loo(x[, 1], psis_vec, type = "sd", log_ratios = log_rats[,1]) -E_test_quant_vec <- E_loo(x[, 1], psis_vec, type = "quant", probs = 0.5, log_ratios = log_rats[,1]) -E_test_quant_vec2 <- E_loo(x[, 1], psis_vec, type = "quant", probs = c(0.1, 0.5, 0.9), log_ratios = log_rats[,1]) +E_test_mean_vec <- E_loo( + x[, 1], + psis_vec, + type = "mean", + log_ratios = log_rats[, 1] +) +E_test_var_vec <- E_loo( + x[, 1], + psis_vec, + type = "var", + log_ratios = log_rats[, 1] +) +E_test_sd_vec <- E_loo( + x[, 1], + psis_vec, + type = "sd", + log_ratios = log_rats[, 1] +) +E_test_quant_vec <- E_loo( + x[, 1], + psis_vec, + type = "quant", + probs = 0.5, + log_ratios = log_rats[, 1] +) +E_test_quant_vec2 <- E_loo( + x[, 1], + psis_vec, + type = "quant", + probs = c(0.1, 0.5, 0.9), + log_ratios = log_rats[, 1] +) # E_loo_khat khat <- loo:::E_loo_khat.matrix(x, psis_mat, log_rats) @@ -97,30 +136,60 @@ test_that("E_loo return types correct for default/vector method", { }) test_that("E_loo.default equal to reference", { - expect_equal_to_reference(E_test_mean_vec, test_path("reference-results/E_loo_default_mean.rds")) - expect_equal_to_reference(E_test_var_vec, test_path("reference-results/E_loo_default_var.rds")) - expect_equal_to_reference(E_test_sd_vec, test_path("reference-results/E_loo_default_sd.rds")) - expect_equal_to_reference(E_test_quant_vec, test_path("reference-results/E_loo_default_quantile_50.rds")) - expect_equal_to_reference(E_test_quant_vec2, test_path("reference-results/E_loo_default_quantile_10_50_90.rds")) + expect_equal_to_reference( + E_test_mean_vec, + test_path("reference-results/E_loo_default_mean.rds") + ) + expect_equal_to_reference( + E_test_var_vec, + test_path("reference-results/E_loo_default_var.rds") + ) + expect_equal_to_reference( + E_test_sd_vec, + test_path("reference-results/E_loo_default_sd.rds") + ) + expect_equal_to_reference( + E_test_quant_vec, + test_path("reference-results/E_loo_default_quantile_50.rds") + ) + expect_equal_to_reference( + E_test_quant_vec2, + test_path("reference-results/E_loo_default_quantile_10_50_90.rds") + ) }) test_that("E_loo.matrix equal to reference", { - expect_equal_to_reference(E_test_mean, test_path("reference-results/E_loo_matrix_mean.rds")) - expect_equal_to_reference(E_test_var, test_path("reference-results/E_loo_matrix_var.rds")) - expect_equal_to_reference(E_test_sd, test_path("reference-results/E_loo_matrix_sd.rds")) - expect_equal_to_reference(E_test_quant, test_path("reference-results/E_loo_matrix_quantile_50.rds")) - expect_equal_to_reference(E_test_quant2, test_path("reference-results/E_loo_matrix_quantile_10_90.rds")) + expect_equal_to_reference( + E_test_mean, + test_path("reference-results/E_loo_matrix_mean.rds") + ) + expect_equal_to_reference( + E_test_var, + test_path("reference-results/E_loo_matrix_var.rds") + ) + expect_equal_to_reference( + E_test_sd, + test_path("reference-results/E_loo_matrix_sd.rds") + ) + expect_equal_to_reference( + E_test_quant, + test_path("reference-results/E_loo_matrix_quantile_50.rds") + ) + expect_equal_to_reference( + E_test_quant2, + test_path("reference-results/E_loo_matrix_quantile_10_90.rds") + ) }) test_that("E_loo throws correct errors and warnings", { # warnings expect_no_warning(E_loo.matrix(x, psis_mat)) # no warnings if x is constant, binary, NA, NaN, Inf - expect_no_warning(E_loo.matrix(x*0, psis_mat)) - expect_no_warning(E_loo.matrix(0+(x>0), psis_mat)) - expect_no_warning(E_loo.matrix(x+NA, psis_mat)) - expect_no_warning(E_loo.matrix(x*NaN, psis_mat)) - expect_no_warning(E_loo.matrix(x*Inf, psis_mat)) + expect_no_warning(E_loo.matrix(x * 0, psis_mat)) + expect_no_warning(E_loo.matrix(0 + (x > 0), psis_mat)) + expect_no_warning(E_loo.matrix(x + NA, psis_mat)) + expect_no_warning(E_loo.matrix(x * NaN, psis_mat)) + expect_no_warning(E_loo.matrix(x * Inf, psis_mat)) expect_no_warning(E_test <- E_loo.default(x[, 1], psis_vec)) expect_length(E_test$pareto_k, 1) @@ -163,7 +232,6 @@ test_that("weighted quantiles work", { quantile(xx, probs, names = FALSE) } - set.seed(123) pr <- seq(0.025, 0.975, 0.025) diff --git a/tests/testthat/test_compare.R b/tests/testthat/test_compare.R index 8835a530..6874c503 100644 --- a/tests/testthat/test_compare.R +++ b/tests/testthat/test_compare.R @@ -15,9 +15,11 @@ test_that("loo_compare throws appropriate errors", { w4 <- SW(waic(LLarr[,, -(1:2)])) expect_error(loo_compare(2, 3), "must be a list if not a 'loo' object") - expect_error(loo_compare(w1, w2, x = list(w1, w2)), - "If 'x' is a list then '...' should not be specified") - expect_error(loo_compare(w1, list(1,2,3)), "class 'loo'") + expect_error( + loo_compare(w1, w2, x = list(w1, w2)), + "If 'x' is a list then '...' should not be specified" + ) + expect_error(loo_compare(w1, list(1, 2, 3)), "class 'loo'") expect_error(loo_compare(w1), "requires at least two models") expect_error(loo_compare(x = list(w1)), "requires at least two models") expect_error(loo_compare(w1, w3), "same number of data points") @@ -25,35 +27,47 @@ test_that("loo_compare throws appropriate errors", { }) test_that("loo_compare throws appropriate warnings", { - w3 <- w1; w4 <- w2 + w3 <- w1 + w4 <- w2 class(w3) <- class(w4) <- c("kfold", "loo") attr(w3, "K") <- 2 attr(w4, "K") <- 3 - expect_warning(loo_compare(w3, w4), "Not all kfold objects have the same K value") + expect_warning( + loo_compare(w3, w4), + "Not all kfold objects have the same K value" + ) class(w4) <- c("psis_loo", "loo") attr(w4, "K") <- NULL expect_warning(loo_compare(w3, w4), "Comparing LOO-CV to K-fold-CV") - w3 <- w1; w4 <- w2 + w3 <- w1 + w4 <- w2 attr(w3, "yhash") <- "a" attr(w4, "yhash") <- "b" expect_warning(loo_compare(w3, w4), "Not all models have the same y variable") set.seed(123) w_list <- lapply(1:25, function(x) SW(waic(LLarr + rnorm(1, 0, 0.1)))) - expect_warning(loo_compare(w_list), - "Difference in performance potentially due to chance") + expect_warning( + loo_compare(w_list), + "Difference in performance potentially due to chance" + ) w_list_short <- lapply(1:4, function(x) SW(waic(LLarr + rnorm(1, 0, 0.1)))) expect_no_warning(loo_compare(w_list_short)) }) - comp_colnames <- c( - "elpd_diff", "se_diff", "elpd_waic", "se_elpd_waic", - "p_waic", "se_p_waic", "waic", "se_waic" + "elpd_diff", + "se_diff", + "elpd_waic", + "se_elpd_waic", + "p_waic", + "se_p_waic", + "waic", + "se_waic" ) test_that("loo_compare returns expected results (2 models)", { @@ -62,14 +76,16 @@ test_that("loo_compare returns expected results (2 models)", { expect_equal(colnames(comp1), comp_colnames) expect_equal(rownames(comp1), c("model1", "model2")) expect_output(print(comp1), "elpd_diff") - expect_equivalent(comp1[1:2,1], c(0, 0)) - expect_equivalent(comp1[1:2,2], c(0, 0)) + expect_equivalent(comp1[1:2, 1], c(0, 0)) + expect_equivalent(comp1[1:2, 2], c(0, 0)) comp2 <- loo_compare(w1, w2) expect_s3_class(comp2, "compare.loo") # expect_equal_to_reference(comp2, "reference-results/loo_compare_two_models.rds") - comp2_ref <- readRDS(test_path("reference-results/loo_compare_two_models.rds")) + comp2_ref <- readRDS(test_path( + "reference-results/loo_compare_two_models.rds" + )) expect_equivalent(comp2, comp2_ref) expect_equal(colnames(comp2), comp_colnames) @@ -84,12 +100,14 @@ test_that("loo_compare returns expected result (3 models)", { expect_equal(colnames(comp1), comp_colnames) expect_equal(rownames(comp1), c("model1", "model2", "model3")) - expect_equal(comp1[1,1], 0) + expect_equal(comp1[1, 1], 0) expect_s3_class(comp1, "compare.loo") expect_s3_class(comp1, "matrix") # expect_equal_to_reference(comp1, "reference-results/loo_compare_three_models.rds") - comp1_ref <- readRDS(test_path("reference-results/loo_compare_three_models.rds")) + comp1_ref <- readRDS(test_path( + "reference-results/loo_compare_three_models.rds" + )) expect_equivalent(comp1, comp1_ref) # specifying objects via '...' gives equivalent results (equal @@ -126,34 +144,53 @@ test_that("compare returns expected result (3 models)", { expect_equal( colnames(comp1), c( - "elpd_diff", "se_diff", "elpd_waic", "se_elpd_waic", - "p_waic", "se_p_waic", "waic", "se_waic" - )) + "elpd_diff", + "se_diff", + "elpd_waic", + "se_elpd_waic", + "p_waic", + "se_p_waic", + "waic", + "se_waic" + ) + ) expect_equal(rownames(comp1), c("w1", "w2", "w3")) - expect_equal(comp1[1,1], 0) + expect_equal(comp1[1, 1], 0) expect_s3_class(comp1, "compare.loo") expect_s3_class(comp1, "matrix") # expect_equal_to_reference(comp1, "reference-results/compare_three_models.rds") # specifying objects via '...' gives equivalent results (equal # except rownames) to using 'x' argument - comp_via_list <- expect_warning(loo::compare(x = list(w1, w2, w3)), "Deprecated") + comp_via_list <- expect_warning( + loo::compare(x = list(w1, w2, w3)), + "Deprecated" + ) expect_equivalent(comp1, comp_via_list) }) test_that("compare throws appropriate errors", { - expect_error(suppressWarnings(loo::compare(w1, w2, x = list(w1, w2))), - "should not be specified") - expect_error(suppressWarnings(loo::compare(x = 2)), - "must be a list") - expect_error(suppressWarnings(loo::compare(x = list(2))), - "should have class 'loo'") - expect_error(suppressWarnings(loo::compare(x = list(w1))), - "requires at least two models") - - w3 <- SW(waic(LLarr2[,,-1])) - expect_error(suppressWarnings(loo::compare(x = list(w1, w3))), - "same number of data points") - expect_error(suppressWarnings(loo::compare(x = list(w1, w2, w3))), - "same number of data points") + expect_error( + suppressWarnings(loo::compare(w1, w2, x = list(w1, w2))), + "should not be specified" + ) + expect_error(suppressWarnings(loo::compare(x = 2)), "must be a list") + expect_error( + suppressWarnings(loo::compare(x = list(2))), + "should have class 'loo'" + ) + expect_error( + suppressWarnings(loo::compare(x = list(w1))), + "requires at least two models" + ) + + w3 <- SW(waic(LLarr2[,, -1])) + expect_error( + suppressWarnings(loo::compare(x = list(w1, w3))), + "same number of data points" + ) + expect_error( + suppressWarnings(loo::compare(x = list(w1, w2, w3))), + "same number of data points" + ) }) diff --git a/tests/testthat/test_crps.R b/tests/testthat/test_crps.R index 9c1f50cd..9e9d52db 100644 --- a/tests/testthat/test_crps.R +++ b/tests/testthat/test_crps.R @@ -21,38 +21,62 @@ test_that("crps computation is correct", { expect_equal(.crps_fun(1.0, 0.0, scale = TRUE), 0.0) expect_equal(.crps_fun(1.0, 2.0, scale = TRUE), -2.0) - expect_equal(.crps_fun(pi, pi^2, scale = TRUE), -pi^2/pi - 0.5 * log(pi)) + expect_equal(.crps_fun(pi, pi^2, scale = TRUE), -pi^2 / pi - 0.5 * log(pi)) }) test_that("crps matches references", { - expect_equal_to_reference(with_seed(1, crps(x1, x2, y)), 'reference-results/crps.rds') - expect_equal_to_reference(with_seed(1, scrps(x1, x2, y)), 'reference-results/scrps.rds') - expect_equal_to_reference(with_seed(1, loo_crps(x1, x2, y, ll)), 'reference-results/loo_crps.rds') - expect_equal_to_reference(with_seed(1, loo_scrps(x1, x2, y, ll)), 'reference-results/loo_scrps.rds') + expect_equal_to_reference( + with_seed(1, crps(x1, x2, y)), + 'reference-results/crps.rds' + ) + expect_equal_to_reference( + with_seed(1, scrps(x1, x2, y)), + 'reference-results/scrps.rds' + ) + expect_equal_to_reference( + with_seed(1, loo_crps(x1, x2, y, ll)), + 'reference-results/loo_crps.rds' + ) + expect_equal_to_reference( + with_seed(1, loo_scrps(x1, x2, y, ll)), + 'reference-results/loo_scrps.rds' + ) }) test_that("input validation throws correct errors", { - expect_error(validate_crps_input(as.character(x1), x2, y), - "is.numeric(x) is not TRUE", - fixed = TRUE) - expect_error(validate_crps_input(x1, as.character(x2), y), - "is.numeric(x2) is not TRUE", - fixed = TRUE) - expect_error(validate_crps_input(x1, x2, c('a', 'b')), - "is.numeric(y) is not TRUE", - fixed = TRUE) - expect_error(validate_crps_input(x1, t(x2), y), - "identical(dim(x), dim(x2)) is not TRUE", - fixed = TRUE) - expect_error(validate_crps_input(x1, x2, c(1, 2)), - "ncol(x) == length(y) is not TRUE", - fixed = TRUE) - expect_error(validate_crps_input(x1, x2, y, t(ll)), - "ifelse(is.null(log_lik), TRUE, identical(dim(log_lik), dim(x))) is not TRUE", - fixed = TRUE) + expect_error( + validate_crps_input(as.character(x1), x2, y), + "is.numeric(x) is not TRUE", + fixed = TRUE + ) + expect_error( + validate_crps_input(x1, as.character(x2), y), + "is.numeric(x2) is not TRUE", + fixed = TRUE + ) + expect_error( + validate_crps_input(x1, x2, c('a', 'b')), + "is.numeric(y) is not TRUE", + fixed = TRUE + ) + expect_error( + validate_crps_input(x1, t(x2), y), + "identical(dim(x), dim(x2)) is not TRUE", + fixed = TRUE + ) + expect_error( + validate_crps_input(x1, x2, c(1, 2)), + "ncol(x) == length(y) is not TRUE", + fixed = TRUE + ) + expect_error( + validate_crps_input(x1, x2, y, t(ll)), + "ifelse(is.null(log_lik), TRUE, identical(dim(log_lik), dim(x))) is not TRUE", + fixed = TRUE + ) }) test_that("methods for single data point don't error", { - expect_silent(crps(x1[,1], x2[,1], y[1])) - expect_silent(scrps(x1[,1], x2[,1], y[1])) + expect_silent(crps(x1[, 1], x2[, 1], y[1])) + expect_silent(scrps(x1[, 1], x2[, 1], y[1])) }) diff --git a/tests/testthat/test_deprecated_extractors.R b/tests/testthat/test_deprecated_extractors.R index 39433d21..e1b1afd7 100644 --- a/tests/testthat/test_deprecated_extractors.R +++ b/tests/testthat/test_deprecated_extractors.R @@ -20,7 +20,10 @@ test_that("extracting estimates by name is deprecated for loo objects", { loo1$estimates["elpd_loo", "Estimate"] ) expect_equal( - expect_warning_fixed(loo1$se_elpd_loo, "se_elpd_loo using '$' is deprecated"), + expect_warning_fixed( + loo1$se_elpd_loo, + "se_elpd_loo using '$' is deprecated" + ), loo1$estimates["elpd_loo", "SE"] ) expect_equal( @@ -42,11 +45,16 @@ test_that("extracting estimates by name is deprecated for loo objects", { # [ method expect_equal( - expect_warning_fixed(loo1["elpd_loo"], "elpd_loo using '[' is deprecated")[[1]], + expect_warning_fixed(loo1["elpd_loo"], "elpd_loo using '[' is deprecated")[[ + 1 + ]], loo1$estimates["elpd_loo", "Estimate"] ) expect_equal( - expect_warning_fixed(loo1["se_elpd_loo"], "se_elpd_loo using '[' is deprecated")[[1]], + expect_warning_fixed( + loo1["se_elpd_loo"], + "se_elpd_loo using '[' is deprecated" + )[[1]], loo1$estimates["elpd_loo", "SE"] ) expect_equal( @@ -54,7 +62,9 @@ test_that("extracting estimates by name is deprecated for loo objects", { loo1$estimates["p_loo", "Estimate"] ) expect_equal( - expect_warning_fixed(loo1["se_p_loo"], "se_p_loo using '[' is deprecated")[[1]], + expect_warning_fixed(loo1["se_p_loo"], "se_p_loo using '[' is deprecated")[[ + 1 + ]], loo1$estimates["p_loo", "SE"] ) expect_equal( @@ -62,18 +72,25 @@ test_that("extracting estimates by name is deprecated for loo objects", { loo1$estimates["looic", "Estimate"] ) expect_equal( - expect_warning_fixed(loo1["se_looic"], "se_looic using '[' is deprecated")[[1]], + expect_warning_fixed(loo1["se_looic"], "se_looic using '[' is deprecated")[[ + 1 + ]], loo1$estimates["looic", "SE"] ) - # [[ method expect_equal( - expect_warning_fixed(loo1[["elpd_loo"]], "elpd_loo using '[[' is deprecated"), + expect_warning_fixed( + loo1[["elpd_loo"]], + "elpd_loo using '[[' is deprecated" + ), loo1$estimates["elpd_loo", "Estimate"] ) expect_equal( - expect_warning_fixed(loo1[["se_elpd_loo"]], "se_elpd_loo using '[[' is deprecated"), + expect_warning_fixed( + loo1[["se_elpd_loo"]], + "se_elpd_loo using '[[' is deprecated" + ), loo1$estimates["elpd_loo", "SE"] ) expect_equal( @@ -81,7 +98,10 @@ test_that("extracting estimates by name is deprecated for loo objects", { loo1$estimates["p_loo", "Estimate"] ) expect_equal( - expect_warning_fixed(loo1[["se_p_loo"]], "se_p_loo using '[[' is deprecated"), + expect_warning_fixed( + loo1[["se_p_loo"]], + "se_p_loo using '[[' is deprecated" + ), loo1$estimates["p_loo", "SE"] ) expect_equal( @@ -89,7 +109,10 @@ test_that("extracting estimates by name is deprecated for loo objects", { loo1$estimates["looic", "Estimate"] ) expect_equal( - expect_warning_fixed(loo1[["se_looic"]], "se_looic using '[[' is deprecated"), + expect_warning_fixed( + loo1[["se_looic"]], + "se_looic using '[[' is deprecated" + ), loo1$estimates["looic", "SE"] ) }) @@ -100,7 +123,10 @@ test_that("extracting estimates by name is deprecated for waic objects", { waic1$estimates["elpd_waic", "Estimate"] ) expect_equal( - expect_warning_fixed(waic1$se_elpd_waic, "se_elpd_waic using '$' is deprecated"), + expect_warning_fixed( + waic1$se_elpd_waic, + "se_elpd_waic using '$' is deprecated" + ), waic1$estimates["elpd_waic", "SE"] ) expect_equal( @@ -120,21 +146,31 @@ test_that("extracting estimates by name is deprecated for waic objects", { waic1$estimates["waic", "SE"] ) - expect_equal( - expect_warning_fixed(waic1["elpd_waic"], "elpd_waic using '[' is deprecated")[[1]], + expect_warning_fixed( + waic1["elpd_waic"], + "elpd_waic using '[' is deprecated" + )[[1]], waic1$estimates["elpd_waic", "Estimate"] ) expect_equal( - expect_warning_fixed(waic1["se_elpd_waic"], "se_elpd_waic using '[' is deprecated")[[1]], + expect_warning_fixed( + waic1["se_elpd_waic"], + "se_elpd_waic using '[' is deprecated" + )[[1]], waic1$estimates["elpd_waic", "SE"] ) expect_equal( - expect_warning_fixed(waic1["p_waic"], "p_waic using '[' is deprecated")[[1]], + expect_warning_fixed(waic1["p_waic"], "p_waic using '[' is deprecated")[[ + 1 + ]], waic1$estimates["p_waic", "Estimate"] ) expect_equal( - expect_warning_fixed(waic1["se_p_waic"], "se_p_waic using '[' is deprecated")[[1]], + expect_warning_fixed( + waic1["se_p_waic"], + "se_p_waic using '[' is deprecated" + )[[1]], waic1$estimates["p_waic", "SE"] ) expect_equal( @@ -142,17 +178,24 @@ test_that("extracting estimates by name is deprecated for waic objects", { waic1$estimates["waic", "Estimate"] ) expect_equal( - expect_warning_fixed(waic1["se_waic"], "se_waic using '[' is deprecated")[[1]], + expect_warning_fixed(waic1["se_waic"], "se_waic using '[' is deprecated")[[ + 1 + ]], waic1$estimates["waic", "SE"] ) - expect_equal( - expect_warning_fixed(waic1[["elpd_waic"]], "elpd_waic using '[[' is deprecated"), + expect_warning_fixed( + waic1[["elpd_waic"]], + "elpd_waic using '[[' is deprecated" + ), waic1$estimates["elpd_waic", "Estimate"] ) expect_equal( - expect_warning_fixed(waic1[["se_elpd_waic"]], "se_elpd_waic using '[[' is deprecated"), + expect_warning_fixed( + waic1[["se_elpd_waic"]], + "se_elpd_waic using '[[' is deprecated" + ), waic1$estimates["elpd_waic", "SE"] ) expect_equal( @@ -160,7 +203,10 @@ test_that("extracting estimates by name is deprecated for waic objects", { waic1$estimates["p_waic", "Estimate"] ) expect_equal( - expect_warning_fixed(waic1[["se_p_waic"]], "se_p_waic using '[[' is deprecated"), + expect_warning_fixed( + waic1[["se_p_waic"]], + "se_p_waic using '[[' is deprecated" + ), waic1$estimates["p_waic", "SE"] ) expect_equal( @@ -168,7 +214,10 @@ test_that("extracting estimates by name is deprecated for waic objects", { waic1$estimates["waic", "Estimate"] ) expect_equal( - expect_warning_fixed(waic1[["se_waic"]], "se_waic using '[[' is deprecated"), + expect_warning_fixed( + waic1[["se_waic"]], + "se_waic using '[[' is deprecated" + ), waic1$estimates["waic", "SE"] ) }) diff --git a/tests/testthat/test_gpdfit.R b/tests/testthat/test_gpdfit.R index 97c57555..9b195ebd 100644 --- a/tests/testthat/test_gpdfit.R +++ b/tests/testthat/test_gpdfit.R @@ -5,20 +5,23 @@ context("generalized pareto") test_that("gpdfit returns correct result", { set.seed(123) x <- rexp(100) - gpdfit_val_old <- unlist(gpdfit(x, wip=FALSE, min_grid_pts = 80)) + gpdfit_val_old <- unlist(gpdfit(x, wip = FALSE, min_grid_pts = 80)) expect_equal_to_reference(gpdfit_val_old, "reference-results/gpdfit_old.rds") - gpdfit_val_wip <- unlist(gpdfit(x, wip=TRUE, min_grid_pts = 80)) + gpdfit_val_wip <- unlist(gpdfit(x, wip = TRUE, min_grid_pts = 80)) expect_equal_to_reference(gpdfit_val_wip, "reference-results/gpdfit.rds") - gpdfit_val_wip_default_grid <- unlist(gpdfit(x, wip=TRUE)) - expect_equal_to_reference(gpdfit_val_wip_default_grid, "reference-results/gpdfit_default_grid.rds") + gpdfit_val_wip_default_grid <- unlist(gpdfit(x, wip = TRUE)) + expect_equal_to_reference( + gpdfit_val_wip_default_grid, + "reference-results/gpdfit_default_grid.rds" + ) }) test_that("qgpd returns the correct result ", { probs <- seq(from = 0, to = 1, by = 0.25) q1 <- qgpd(probs, k = 1, sigma = 1) - expect_equal(q1, c(0, 1/3, 1, 3, Inf)) + expect_equal(q1, c(0, 1 / 3, 1, 3, Inf)) q2 <- qgpd(probs, k = 1, sigma = 0) expect_true(all(is.nan(q2))) diff --git a/tests/testthat/test_kfold_helpers.R b/tests/testthat/test_kfold_helpers.R index c613cafa..f9b5c4a4 100644 --- a/tests/testthat/test_kfold_helpers.R +++ b/tests/testthat/test_kfold_helpers.R @@ -29,7 +29,9 @@ test_that("kfold_split_stratified works", { expect_silent(fold_strat <- kfold_split_stratified(5, y)) # used to be a warning before fixing issue #277 tab <- table(fold_strat, y) expect_equal(tab[1, ], c("1" = 4, "2" = 8, "3" = 1)) - for (i in 2:nrow(tab)) expect_equal(tab[i, ], c("1" = 4, "2" = 8, "3" = 0)) + for (i in 2:nrow(tab)) { + expect_equal(tab[i, ], c("1" = 4, "2" = 8, "3" = 0)) + } }) test_that("kfold_split_grouped works", { @@ -47,33 +49,93 @@ test_that("kfold_split_grouped works", { fold_group <- kfold_split_grouped(K = 10, x = grp) expect_equal(sum(table(fold_group)), length(grp) - 4) - grp <- rep(c("A","B"), each = 20) + grp <- rep(c("A", "B"), each = 20) fold_group <- kfold_split_grouped(K = 2, x = grp) expect_equal(fold_group, as.integer(as.factor(grp))) }) test_that("kfold helpers throw correct errors", { expect_error(kfold_split_random(10), "!is.null(N) is not TRUE", fixed = TRUE) - expect_error(kfold_split_random(10.5, 100), "K == as.integer(K) is not TRUE", fixed = TRUE) - expect_error(kfold_split_random(10, 100.5), "N == as.integer(N) is not TRUE", fixed = TRUE) - expect_error(kfold_split_random(K = c(1,1), N = 100), "length(K) == 1 is not TRUE", fixed = TRUE) - expect_error(kfold_split_random(N = c(100, 100)), "length(N) == 1 is not TRUE", fixed = TRUE) - expect_error(kfold_split_random(K = 5, N = 4), "K <= N is not TRUE", fixed = TRUE) - expect_error(kfold_split_random(K = 1, N = 4), "K > 1 is not TRUE", fixed = TRUE) + expect_error( + kfold_split_random(10.5, 100), + "K == as.integer(K) is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_random(10, 100.5), + "N == as.integer(N) is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_random(K = c(1, 1), N = 100), + "length(K) == 1 is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_random(N = c(100, 100)), + "length(N) == 1 is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_random(K = 5, N = 4), + "K <= N is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_random(K = 1, N = 4), + "K > 1 is not TRUE", + fixed = TRUE + ) y <- sample(c(0, 1), size = 200, replace = TRUE, prob = c(0.05, 0.95)) - expect_error(kfold_split_stratified(10), "!is.null(x) is not TRUE", fixed = TRUE) - expect_error(kfold_split_stratified(10.5, y), "K == as.integer(K) is not TRUE", fixed = TRUE) - expect_error(kfold_split_stratified(K = c(1,1), y), "length(K) == 1 is not TRUE", fixed = TRUE) - expect_error(kfold_split_stratified(K = 201, y), "K <= length(x) is not TRUE", fixed = TRUE) - expect_error(kfold_split_stratified(K = 1, y), "K > 1 is not TRUE", fixed = TRUE) + expect_error( + kfold_split_stratified(10), + "!is.null(x) is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_stratified(10.5, y), + "K == as.integer(K) is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_stratified(K = c(1, 1), y), + "length(K) == 1 is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_stratified(K = 201, y), + "K <= length(x) is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_stratified(K = 1, y), + "K > 1 is not TRUE", + fixed = TRUE + ) grp <- gl(n = 50, k = 15) expect_error(kfold_split_grouped(10), "!is.null(x) is not TRUE", fixed = TRUE) - expect_error(kfold_split_grouped(3, c(1,1,1)), "'K' must not be bigger than the number of levels/groups in 'x'", fixed = TRUE) - expect_error(kfold_split_grouped(10.5, grp), "K == as.integer(K) is not TRUE", fixed = TRUE) - expect_error(kfold_split_grouped(K = c(1,1), grp), "length(K) == 1 is not TRUE", fixed = TRUE) - expect_error(kfold_split_grouped(K = 1, grp), "K > 1 is not TRUE", fixed = TRUE) + expect_error( + kfold_split_grouped(3, c(1, 1, 1)), + "'K' must not be bigger than the number of levels/groups in 'x'", + fixed = TRUE + ) + expect_error( + kfold_split_grouped(10.5, grp), + "K == as.integer(K) is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_grouped(K = c(1, 1), grp), + "length(K) == 1 is not TRUE", + fixed = TRUE + ) + expect_error( + kfold_split_grouped(K = 1, grp), + "K > 1 is not TRUE", + fixed = TRUE + ) }) @@ -84,4 +146,3 @@ test_that("print_dims.kfold works", { attr(xx, "K") <- NULL expect_silent(print_dims(xx)) }) - diff --git a/tests/testthat/test_loo_and_waic.R b/tests/testthat/test_loo_and_waic.R index d43de50e..8f8c4a29 100644 --- a/tests/testthat/test_loo_and_waic.R +++ b/tests/testthat/test_loo_and_waic.R @@ -84,7 +84,10 @@ test_that("loo returns object with correct structure", { expect_named(loo1$diagnostics, c("pareto_k", "n_eff", "r_eff")) expect_equal(dimnames(loo1$estimates)[[1]], c("elpd_loo", "p_loo", "looic")) expect_equal(dimnames(loo1$estimates)[[2]], c("Estimate", "SE")) - expect_equal(colnames(loo1$pointwise), c("elpd_loo", "mcse_elpd_loo", "p_loo", "looic", "influence_pareto_k")) + expect_equal( + colnames(loo1$pointwise), + c("elpd_loo", "mcse_elpd_loo", "p_loo", "looic", "influence_pareto_k") + ) expect_equal(dim(loo1), dim(LLmat)) }) @@ -107,7 +110,10 @@ test_that("elpd returns object with correct structure", { test_that("two pareto k values are equal", { - expect_identical(loo1$pointwise[,"influence_pareto_k"], loo1$diagnostics$pareto_k) + expect_identical( + loo1$pointwise[, "influence_pareto_k"], + loo1$diagnostics$pareto_k + ) }) test_that("loo.array and loo.matrix give same result", { @@ -143,32 +149,55 @@ test_that("loo, waic, and elpd error with vector input", { }) - # testing function methods ------------------------------------------------ source(test_path("data-for-tests/function_method_stuff.R")) waic_with_fn <- waic(llfun, data = data, draws = draws) waic_with_mat <- waic(llmat_from_fn) -loo_with_fn <- loo(llfun, data = data, draws = draws, - r_eff = rep(1, nrow(data))) -loo_with_mat <- loo(llmat_from_fn, r_eff = rep(1, ncol(llmat_from_fn)), - save_psis = TRUE) +loo_with_fn <- loo( + llfun, + data = data, + draws = draws, + r_eff = rep(1, nrow(data)) +) +loo_with_mat <- loo( + llmat_from_fn, + r_eff = rep(1, ncol(llmat_from_fn)), + save_psis = TRUE +) test_that("loo.cores deprecation warning works with function method", { options(loo.cores = 1) - expect_warning(loo(llfun, cores = 2, data = data, draws = draws, r_eff = rep(1, nrow(data))), - "loo.cores") - options(loo.cores=NULL) + expect_warning( + loo( + llfun, + cores = 2, + data = data, + draws = draws, + r_eff = rep(1, nrow(data)) + ), + "loo.cores" + ) + options(loo.cores = NULL) }) test_that("loo_i results match loo results for ith data point", { expect_no_warning( loo_i_val <- loo_i(i = 2, llfun = llfun, data = data, draws = draws), ) - expect_equal(loo_i_val$pointwise[, "elpd_loo"], loo_with_fn$pointwise[2, "elpd_loo"]) - expect_equal(loo_i_val$pointwise[, "p_loo"], loo_with_fn$pointwise[2, "p_loo"]) - expect_equal(loo_i_val$diagnostics$pareto_k, loo_with_fn$diagnostics$pareto_k[2]) + expect_equal( + loo_i_val$pointwise[, "elpd_loo"], + loo_with_fn$pointwise[2, "elpd_loo"] + ) + expect_equal( + loo_i_val$pointwise[, "p_loo"], + loo_with_fn$pointwise[2, "p_loo"] + ) + expect_equal( + loo_i_val$diagnostics$pareto_k, + loo_with_fn$diagnostics$pareto_k[2] + ) expect_equal(loo_i_val$diagnostics$n_eff, loo_with_fn$diagnostics$n_eff[2]) }) @@ -180,16 +209,31 @@ test_that("function and matrix methods return same result", { }) test_that("loo.function runs with multiple cores", { - loo_with_fn1 <- loo(llfun, data = data, draws = draws, - r_eff = rep(1, nrow(data)), cores = 1) - loo_with_fn2 <- loo(llfun, data = data, draws = draws, - r_eff = rep(1, nrow(data)), cores = 2) + loo_with_fn1 <- loo( + llfun, + data = data, + draws = draws, + r_eff = rep(1, nrow(data)), + cores = 1 + ) + loo_with_fn2 <- loo( + llfun, + data = data, + draws = draws, + r_eff = rep(1, nrow(data)), + cores = 2 + ) expect_identical(loo_with_fn2$estimates, loo_with_fn1$estimates) }) test_that("save_psis option to loo.function makes correct psis object", { - loo_with_fn2 <- loo.function(llfun, data = data, draws = draws, - r_eff = rep(1, nrow(data)), save_psis = TRUE) + loo_with_fn2 <- loo.function( + llfun, + data = data, + draws = draws, + r_eff = rep(1, nrow(data)), + save_psis = TRUE + ) expect_identical(loo_with_fn2$psis_object, loo_with_mat$psis_object) }) @@ -198,4 +242,3 @@ test_that("loo doesn't throw r_eff warnings", { expect_no_warning(loo(-LLmat)) expect_no_warning(loo(llfun, data = data, draws = draws)) }) - diff --git a/tests/testthat/test_loo_approximate_posterior.R b/tests/testthat/test_loo_approximate_posterior.R index e3adf791..0711c605 100644 --- a/tests/testthat/test_loo_approximate_posterior.R +++ b/tests/testthat/test_loo_approximate_posterior.R @@ -12,58 +12,91 @@ a0 <- 1 b0 <- 1 p <- 0.5 y <- rbinom(N, size = K, prob = p) -fake_data <- data.frame(y,K) +fake_data <- data.frame(y, K) # The log posterior log_post <- function(p, y, a0, b0, K) { - log_lik <- sum(dbinom(x = y, size = K, prob = p, log = TRUE)) # the log likelihood - log_post <- log_lik + dbeta(x = p, shape1 = a0, shape2 = b0, log = TRUE) # the log prior + log_lik <- sum(dbinom(x = y, size = K, prob = p, log = TRUE)) # the log likelihood + log_post <- log_lik + dbeta(x = p, shape1 = a0, shape2 = b0, log = TRUE) # the log prior log_post } -it <- optim(par = 0.5, fn = log_post, control = list(fnscale = -1), - hessian = TRUE, y = y, a0 = a0, b0 = b0, K = K, - lower = 0.01, upper = 0.99, method = "Brent") +it <- optim( + par = 0.5, + fn = log_post, + control = list(fnscale = -1), + hessian = TRUE, + y = y, + a0 = a0, + b0 = b0, + K = K, + lower = 0.01, + upper = 0.99, + method = "Brent" +) lap_params <- c(mu = it$par, sd = sqrt(solve(-it$hessian))) a <- a0 + sum(y) b <- b0 + N * K - sum(y) fake_true_posterior <- as.matrix(rbeta(S, a, b)) -fake_laplace_posterior <- as.matrix(rnorm(n = S, mean = lap_params["mu"], sd = lap_params["sd"])) +fake_laplace_posterior <- as.matrix(rnorm( + n = S, + mean = lap_params["mu"], + sd = lap_params["sd"] +)) # mean(fake_laplace_posterior); sd(fake_laplace_posterior) p_draws <- as.vector(fake_laplace_posterior) log_p <- numeric(S) -for(s in 1:S){ +for (s in 1:S) { log_p[s] <- log_post(p_draws[s], y = y, a0 = a0, b0 = b0, K = K) } -log_g <- as.vector(dnorm(as.vector(fake_laplace_posterior), mean = lap_params["mu"], sd = lap_params["sd"], log = TRUE)) +log_g <- as.vector(dnorm( + as.vector(fake_laplace_posterior), + mean = lap_params["mu"], + sd = lap_params["sd"], + log = TRUE +)) llfun <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } ll <- matrix(0, nrow = S, ncol = N) -for(j in 1:N){ - ll[, j] <- llfun(data_i = fake_data[j, , drop=FALSE], draws = fake_laplace_posterior) +for (j in 1:N) { + ll[, j] <- llfun( + data_i = fake_data[j, , drop = FALSE], + draws = fake_laplace_posterior + ) } test_that("loo_approximate_posterior.array works as loo_approximate_posterior.matrix", { - # Create array with two "chains" - log_p_mat <- matrix(log_p, nrow = (S/2), ncol = 2) - log_g_mat <- matrix(log_g, nrow = (S/2), ncol = 2) - ll_array <- array(0, dim = c((S/2), 2 , ncol(ll))) - ll_array[,1,] <- ll[1:(S/2),] - ll_array[,2,] <- ll[(S/2 + 1):S,] + log_p_mat <- matrix(log_p, nrow = (S / 2), ncol = 2) + log_g_mat <- matrix(log_g, nrow = (S / 2), ncol = 2) + ll_array <- array(0, dim = c((S / 2), 2, ncol(ll))) + ll_array[, 1, ] <- ll[1:(S / 2), ] + ll_array[, 2, ] <- ll[(S / 2 + 1):S, ] # Assert that they are ok - expect_equivalent(ll_array[1:2,1,1:2], ll[1:2,1:2]) - expect_equivalent(ll_array[1:2,2,1:2], ll[(S/2+1):((S/2)+2),1:2]) + expect_equivalent(ll_array[1:2, 1, 1:2], ll[1:2, 1:2]) + expect_equivalent(ll_array[1:2, 2, 1:2], ll[(S / 2 + 1):((S / 2) + 2), 1:2]) # Compute aploo - expect_silent(aploo1 <- loo_approximate_posterior.matrix(x = ll, log_p = log_p, log_g = log_g)) - expect_silent(aploo2 <- loo_approximate_posterior.array(x = ll_array, log_p = log_p_mat, log_g = log_g_mat)) + expect_silent( + aploo1 <- loo_approximate_posterior.matrix( + x = ll, + log_p = log_p, + log_g = log_g + ) + ) + expect_silent( + aploo2 <- loo_approximate_posterior.array( + x = ll_array, + log_p = log_p_mat, + log_g = log_g_mat + ) + ) expect_silent(aploo1b <- loo.matrix(x = ll, r_eff = rep(1, N))) # Check equivalence @@ -73,24 +106,53 @@ test_that("loo_approximate_posterior.array works as loo_approximate_posterior.ma expect_failure(expect_equal(class(aploo1), class(aploo1b))) # Should fail with matrix - expect_error(aploo2 <- loo_approximate_posterior.matrix(x = ll, log_p = as.matrix(log_p), log_g = log_g)) - expect_error(aploo2 <- loo_approximate_posterior.matrix(x = ll, log_p = as.matrix(log_p), log_g = as.matrix(log_g))) + expect_error( + aploo2 <- loo_approximate_posterior.matrix( + x = ll, + log_p = as.matrix(log_p), + log_g = log_g + ) + ) + expect_error( + aploo2 <- loo_approximate_posterior.matrix( + x = ll, + log_p = as.matrix(log_p), + log_g = as.matrix(log_g) + ) + ) # Expect log_p and log_g be stored in the approximate_posterior in the same way expect_length(aploo1$approximate_posterior$log_p, nrow(ll)) expect_length(aploo1$approximate_posterior$log_g, nrow(ll)) - expect_equal(aploo1$approximate_posterior$log_p, aploo2$approximate_posterior$log_p) - expect_equal(aploo1$approximate_posterior$log_g, aploo2$approximate_posterior$log_g) - + expect_equal( + aploo1$approximate_posterior$log_p, + aploo2$approximate_posterior$log_p + ) + expect_equal( + aploo1$approximate_posterior$log_g, + aploo2$approximate_posterior$log_g + ) }) test_that("loo_approximate_posterior.function works as loo_approximate_posterior.matrix", { - - # Compute aploo - expect_silent(aploo1 <- loo_approximate_posterior.matrix(x = ll, log_p = log_p, log_g = log_g)) + expect_silent( + aploo1 <- loo_approximate_posterior.matrix( + x = ll, + log_p = log_p, + log_g = log_g + ) + ) expect_silent(aploo1b <- loo.matrix(x = ll, r_eff = rep(1, N))) - expect_silent(aploo2 <- loo_approximate_posterior.function(x = llfun, log_p = log_p, log_g = log_g, data = fake_data, draws = fake_laplace_posterior)) + expect_silent( + aploo2 <- loo_approximate_posterior.function( + x = llfun, + log_p = log_p, + log_g = log_g, + data = fake_data, + draws = fake_laplace_posterior + ) + ) # Check equivalence expect_equal(aploo1$estimates, aploo2$estimates) @@ -99,11 +161,20 @@ test_that("loo_approximate_posterior.function works as loo_approximate_posterior # Check equivalence # Expect log_p and log_g be stored in the approximate_posterior in the same way - expect_length(aploo2$approximate_posterior$log_p, nrow(fake_laplace_posterior)) - expect_length(aploo2$approximate_posterior$log_g, nrow(fake_laplace_posterior)) - expect_equal(aploo1$approximate_posterior$log_p, aploo2$approximate_posterior$log_p) - expect_equal(aploo1$approximate_posterior$log_g, aploo2$approximate_posterior$log_g) - + expect_length( + aploo2$approximate_posterior$log_p, + nrow(fake_laplace_posterior) + ) + expect_length( + aploo2$approximate_posterior$log_g, + nrow(fake_laplace_posterior) + ) + expect_equal( + aploo1$approximate_posterior$log_p, + aploo2$approximate_posterior$log_p + ) + expect_equal( + aploo1$approximate_posterior$log_g, + aploo2$approximate_posterior$log_g + ) }) - - diff --git a/tests/testthat/test_loo_moment_matching.R b/tests/testthat/test_loo_moment_matching.R index ae67b20b..c36bf1d3 100644 --- a/tests/testthat/test_loo_moment_matching.R +++ b/tests/testthat/test_loo_moment_matching.R @@ -7,31 +7,48 @@ set.seed(123) S <- 4000 # helper functions for sampling from the posterior distribution -rinvchisq <- function(n, df, scale = 1/df, ...) -{ - if ((length(scale) != 1) & (length(scale) != n)) +rinvchisq <- function(n, df, scale = 1 / df, ...) { + if ((length(scale) != 1) & (length(scale) != n)) { stop("scale should be a scalar or a vector of the same length as x") - if (df <= 0) + } + if (df <= 0) { stop("df must be greater than zero") - if (any(scale <= 0)) + } + if (any(scale <= 0)) { stop("scale must be greater than zero") - return((df*scale)/rchisq(n, df = df)) + } + return((df * scale) / rchisq(n, df = df)) } -dinvchisq <- function(x, df, scale=1/df, log = FALSE, ...) -{ - if (df <= 0) +dinvchisq <- function(x, df, scale = 1 / df, log = FALSE, ...) { + if (df <= 0) { stop("df must be greater than zero") - if (scale <= 0) + } + if (scale <= 0) { stop("scale must be greater than zero") - nu <- df/2 - if (log) - return(ifelse(x > 0, nu*log(nu) - log(gamma(nu)) + nu*log(scale) - - (nu + 1)*log(x) - (nu*scale/x), NA)) - else - return(ifelse(x > 0, - (((nu)^(nu))/gamma(nu)) * (scale^nu) * - (x^(-(nu + 1))) * exp(-nu*scale/x), NA)) + } + nu <- df / 2 + if (log) { + return(ifelse( + x > 0, + nu * + log(nu) - + log(gamma(nu)) + + nu * log(scale) - + (nu + 1) * log(x) - + (nu * scale / x), + NA + )) + } else { + return(ifelse( + x > 0, + (((nu)^(nu)) / gamma(nu)) * + (scale^nu) * + (x^(-(nu + 1))) * + exp(-nu * scale / x), + NA + )) + } } @@ -45,11 +62,15 @@ y_tilde <- 11 y[1] <- y_tilde ymean <- mean(y) -s2 <- sum((y - ymean)^2)/(n - 1) +s2 <- sum((y - ymean)^2) / (n - 1) # draws from the posterior distribution when including all observations draws_full_posterior_sigma2 <- rinvchisq(S, n - 1, s2) -draws_full_posterior_mu <- rnorm(S, ymean, sqrt(draws_full_posterior_sigma2/n)) +draws_full_posterior_mu <- rnorm( + S, + ymean, + sqrt(draws_full_posterior_sigma2 / n) +) # create a dummy model object @@ -66,15 +87,8 @@ x$draws <- data.frame( ) - - - - - - # implement functions for moment matching loo - # extract original posterior draws post_draws_test <- function(x, ...) { as.matrix(x$draws) @@ -82,42 +96,50 @@ post_draws_test <- function(x, ...) { # extract original log lik draws log_lik_i_test <- function(x, i, ...) { - -0.5*log(2*pi) - log(x$draws$sigma) - 1.0/(2*x$draws$sigma^2)*(x$data$y[i] - x$draws$mu)^2 + -0.5 * + log(2 * pi) - + log(x$draws$sigma) - + 1.0 / (2 * x$draws$sigma^2) * (x$data$y[i] - x$draws$mu)^2 } -loglik <- matrix(0,S,n) +loglik <- matrix(0, S, n) for (j in seq(n)) { - loglik[,j] <- log_lik_i_test(x, j) + loglik[, j] <- log_lik_i_test(x, j) } - # mu, log(sigma) unconstrain_pars_test <- function(x, pars, ...) { upars <- as.matrix(pars) - upars[,2] <- log(upars[,2]) + upars[, 2] <- log(upars[, 2]) upars } log_prob_upars_test <- function(x, upars, ...) { - dinvchisq(exp(upars[,2])^2,x$data$n - 1,x$data$s2, log = TRUE) + - dnorm(upars[,1],x$data$ymean,exp(upars[,2])/sqrt(x$data$n), log = TRUE) + dinvchisq(exp(upars[, 2])^2, x$data$n - 1, x$data$s2, log = TRUE) + + dnorm( + upars[, 1], + x$data$ymean, + exp(upars[, 2]) / sqrt(x$data$n), + log = TRUE + ) } # compute log_lik_i values based on the unconstrained parameters log_lik_i_upars_test <- function(x, upars, i, ...) { - -0.5*log(2*pi) - upars[,2] - 1.0/(2*exp(upars[,2])^2)*(x$data$y[i] - upars[,1])^2 + -0.5 * + log(2 * pi) - + upars[, 2] - + 1.0 / (2 * exp(upars[, 2])^2) * (x$data$y[i] - upars[, 1])^2 } - upars <- unconstrain_pars_test(x, x$draws) -lwi_1 <- -loglik[,1] +lwi_1 <- -loglik[, 1] lwi_1 <- lwi_1 - matrixStats::logSumExp(lwi_1) - test_that("log_prob_upars_test works", { upars <- unconstrain_pars_test(x, x$draws) xloo <- list() @@ -125,13 +147,13 @@ test_that("log_prob_upars_test works", { xloo$data$y <- y[-1] xloo$data$n <- n - 1 xloo$data$ymean <- mean(y[-1]) - xloo$data$s2 <- sum((y[-1] - mean(y[-1]))^2)/(n - 2) + xloo$data$s2 <- sum((y[-1] - mean(y[-1]))^2) / (n - 2) - post1 <- log_prob_upars_test(x,upars) + post1 <- log_prob_upars_test(x, upars) post1 <- post1 - matrixStats::logSumExp(post1) - post2 <- log_prob_upars_test(xloo,upars) + loglik[,1] + post2 <- log_prob_upars_test(xloo, upars) + loglik[, 1] post2 <- post2 - matrixStats::logSumExp(post2) - expect_equal(post1,post2) + expect_equal(post1, post2) }) @@ -140,98 +162,219 @@ test_that("loo_moment_match.default warnings work", { loo_manual <- suppressWarnings(loo(loglik)) loo_manual_tis <- suppressWarnings(loo(loglik, is_method = "tis")) + expect_warning( + loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.5, + split = FALSE, + cov = TRUE, + cores = 1 + ), + "The accuracy of self-normalized importance sampling" + ) - expect_warning(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.5, split = FALSE, - cov = TRUE, cores = 1), "The accuracy of self-normalized importance sampling") - - expect_warning(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - split = FALSE, - cov = TRUE, cores = 1), "The accuracy of self-normalized importance sampling") - - expect_no_warning(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 100, split = TRUE, - cov = TRUE, cores = 1)) - - expect_warning(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 1, - k_thres = 0.5, split = TRUE, - cov = TRUE, cores = 1), "The maximum number of moment matching iterations") - - expect_error(loo_moment_match(x, loo_manual_tis, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.5, split = TRUE, - cov = TRUE, cores = 1), "loo_moment_match currently supports only") -}) + expect_warning( + loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + split = FALSE, + cov = TRUE, + cores = 1 + ), + "The accuracy of self-normalized importance sampling" + ) + expect_no_warning(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 100, + split = TRUE, + cov = TRUE, + cores = 1 + )) + + expect_warning( + loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 1, + k_thres = 0.5, + split = TRUE, + cov = TRUE, + cores = 1 + ), + "The maximum number of moment matching iterations" + ) + expect_error( + loo_moment_match( + x, + loo_manual_tis, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.5, + split = TRUE, + cov = TRUE, + cores = 1 + ), + "loo_moment_match currently supports only" + ) +}) test_that("loo_moment_match.default works", { - # allow -Inf lwi_x <- lwi_1 lwi_x[which.min(lwi_1)] <- -Inf - expect_no_error(suppressWarnings(importance_sampling.default(lwi_1, method = "psis", r_eff = 1, cores = 1))) + expect_no_error(suppressWarnings(importance_sampling.default( + lwi_1, + method = "psis", + r_eff = 1, + cores = 1 + ))) # loo object loo_manual <- suppressWarnings(loo(loglik)) - loo_moment_match_object <- suppressWarnings(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.8, split = FALSE, - cov = TRUE, cores = 1)) + loo_moment_match_object <- suppressWarnings(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.8, + split = FALSE, + cov = TRUE, + cores = 1 + )) # diagnostic Pareto k decreases but influence pareto k stays the same - expect_lt(loo_moment_match_object$diagnostics$pareto_k[1], loo_moment_match_object$pointwise[1,"influence_pareto_k"]) - expect_equal(loo_moment_match_object$pointwise[,"influence_pareto_k"],loo_manual$pointwise[,"influence_pareto_k"]) - expect_equal(loo_moment_match_object$pointwise[,"influence_pareto_k"],loo_manual$diagnostics$pareto_k) - - expect_equal_to_reference(loo_moment_match_object, "reference-results/moment_match_loo_1.rds") - - loo_moment_match_object2 <- suppressWarnings(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.5, split = FALSE, - cov = TRUE, cores = 1)) - - expect_equal_to_reference(loo_moment_match_object2, "reference-results/moment_match_loo_2.rds") + expect_lt( + loo_moment_match_object$diagnostics$pareto_k[1], + loo_moment_match_object$pointwise[1, "influence_pareto_k"] + ) + expect_equal( + loo_moment_match_object$pointwise[, "influence_pareto_k"], + loo_manual$pointwise[, "influence_pareto_k"] + ) + expect_equal( + loo_moment_match_object$pointwise[, "influence_pareto_k"], + loo_manual$diagnostics$pareto_k + ) - loo_moment_match_object3 <- suppressWarnings(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.5, split = TRUE, - cov = TRUE, cores = 1)) + expect_equal_to_reference( + loo_moment_match_object, + "reference-results/moment_match_loo_1.rds" + ) - expect_equal_to_reference(loo_moment_match_object3, "reference-results/moment_match_loo_3.rds") + loo_moment_match_object2 <- suppressWarnings(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.5, + split = FALSE, + cov = TRUE, + cores = 1 + )) + + expect_equal_to_reference( + loo_moment_match_object2, + "reference-results/moment_match_loo_2.rds" + ) - loo_moment_match_object4 <- suppressWarnings(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 100, split = FALSE, - cov = TRUE, cores = 1)) + loo_moment_match_object3 <- suppressWarnings(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.5, + split = TRUE, + cov = TRUE, + cores = 1 + )) + + expect_equal_to_reference( + loo_moment_match_object3, + "reference-results/moment_match_loo_3.rds" + ) - expect_equal(loo_manual,loo_moment_match_object4) + loo_moment_match_object4 <- suppressWarnings(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 100, + split = FALSE, + cov = TRUE, + cores = 1 + )) + + expect_equal(loo_manual, loo_moment_match_object4) loo_manual_with_psis <- suppressWarnings(loo(loglik, save_psis = TRUE)) - loo_moment_match_object5 <- suppressWarnings(loo_moment_match(x, loo_manual_with_psis, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.8, split = FALSE, - cov = TRUE, cores = 1)) - - expect_equal(loo_moment_match_object5$diagnostics,loo_moment_match_object5$psis_object$diagnostics) - - + loo_moment_match_object5 <- suppressWarnings(loo_moment_match( + x, + loo_manual_with_psis, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.8, + split = FALSE, + cov = TRUE, + cores = 1 + )) + + expect_equal( + loo_moment_match_object5$diagnostics, + loo_moment_match_object5$psis_object$diagnostics + ) }) test_that("variance and covariance transformations work", { @@ -239,57 +382,101 @@ test_that("variance and covariance transformations work", { set.seed(8493874) draws_full_posterior_sigma2 <- rinvchisq(S, n - 1, s2) - draws_full_posterior_mu <- rnorm(S, ymean, sqrt(draws_full_posterior_sigma2/n)) + draws_full_posterior_mu <- rnorm( + S, + ymean, + sqrt(draws_full_posterior_sigma2 / n) + ) x$draws <- data.frame( mu = draws_full_posterior_mu, sigma = sqrt(draws_full_posterior_sigma2) ) - loglik <- matrix(0,S,n) + loglik <- matrix(0, S, n) for (j in seq(n)) { - loglik[,j] <- log_lik_i_test(x, j) + loglik[, j] <- log_lik_i_test(x, j) } upars <- unconstrain_pars_test(x, x$draws) - lwi_1 <- -loglik[,1] + lwi_1 <- -loglik[, 1] lwi_1 <- lwi_1 - matrixStats::logSumExp(lwi_1) loo_manual <- suppressWarnings(loo(loglik)) - loo_moment_match_object <- suppressWarnings(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.0, split = FALSE, - cov = TRUE, cores = 1)) - - expect_equal_to_reference(loo_moment_match_object, "reference-results/moment_match_var_and_cov.rds") - + loo_moment_match_object <- suppressWarnings(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.0, + split = FALSE, + cov = TRUE, + cores = 1 + )) + + expect_equal_to_reference( + loo_moment_match_object, + "reference-results/moment_match_var_and_cov.rds" + ) }) test_that("loo_moment_match.default works with multiple cores", { - # loo object loo_manual <- suppressWarnings(loo(loglik)) - loo_moment_match_manual3 <- suppressWarnings(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.5, split = FALSE, - cov = TRUE, cores = 1)) - - loo_moment_match_manual4 <- suppressWarnings(loo_moment_match(x, loo_manual, post_draws_test, log_lik_i_test, - unconstrain_pars_test, log_prob_upars_test, - log_lik_i_upars_test, max_iters = 30L, - k_thres = 0.5, split = FALSE, - cov = TRUE, cores = 2)) - - expect_equal(loo_moment_match_manual3$diagnostics$pareto_k, loo_moment_match_manual4$diagnostics$pareto_k) - expect_equal(loo_moment_match_manual3$diagnostics$n_eff, loo_moment_match_manual4$diagnostics$n_eff) - - expect_equal(loo_moment_match_manual3$estimates, loo_moment_match_manual4$estimates) + loo_moment_match_manual3 <- suppressWarnings(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.5, + split = FALSE, + cov = TRUE, + cores = 1 + )) + + loo_moment_match_manual4 <- suppressWarnings(loo_moment_match( + x, + loo_manual, + post_draws_test, + log_lik_i_test, + unconstrain_pars_test, + log_prob_upars_test, + log_lik_i_upars_test, + max_iters = 30L, + k_thres = 0.5, + split = FALSE, + cov = TRUE, + cores = 2 + )) + + expect_equal( + loo_moment_match_manual3$diagnostics$pareto_k, + loo_moment_match_manual4$diagnostics$pareto_k + ) + expect_equal( + loo_moment_match_manual3$diagnostics$n_eff, + loo_moment_match_manual4$diagnostics$n_eff + ) - expect_equal(loo_moment_match_manual3$pointwise, loo_moment_match_manual4$pointwise, tolerance=5e-4) + expect_equal( + loo_moment_match_manual3$estimates, + loo_moment_match_manual4$estimates + ) + expect_equal( + loo_moment_match_manual3$pointwise, + loo_moment_match_manual4$pointwise, + tolerance = 5e-4 + ) }) @@ -297,51 +484,97 @@ test_that("loo_moment_match_split works", { # skip on M1 Mac until we figure out why this test fails only on M1 Mac skip_if(Sys.info()[["sysname"]] == "Darwin" && R.version$arch == "aarch64") - is_obj_1 <- suppressWarnings(importance_sampling.default(lwi_1, method = "psis", r_eff = 1, cores = 1)) + is_obj_1 <- suppressWarnings(importance_sampling.default( + lwi_1, + method = "psis", + r_eff = 1, + cores = 1 + )) lwi_1_ps <- as.vector(weights(is_obj_1)) split <- loo_moment_match_split( - x, upars, cov = FALSE, total_shift = c(0,0), total_scaling = c(1,1), total_mapping = diag(c(1,1)), i = 1, - log_prob_upars = log_prob_upars_test, log_lik_i_upars = log_lik_i_upars_test, - cores = 1, r_eff_i = 1, is_method = "psis") + x, + upars, + cov = FALSE, + total_shift = c(0, 0), + total_scaling = c(1, 1), + total_mapping = diag(c(1, 1)), + i = 1, + log_prob_upars = log_prob_upars_test, + log_lik_i_upars = log_lik_i_upars_test, + cores = 1, + r_eff_i = 1, + is_method = "psis" + ) - expect_named(split,c("lwi", "lwfi", "log_liki", "r_eff_i")) + expect_named(split, c("lwi", "lwfi", "log_liki", "r_eff_i")) - expect_equal(lwi_1_ps,split$lwi) + expect_equal(lwi_1_ps, split$lwi) split2 <- loo_moment_match_split( - x, upars, cov = FALSE, total_shift = c(-0.1,-0.2), total_scaling = c(0.7,0.7), - total_mapping = matrix(c(1,0.1,0.1,1),2,2), i = 1, - log_prob_upars = log_prob_upars_test, log_lik_i_upars = log_lik_i_upars_test, - cores = 1, r_eff_i = 1, is_method = "psis") + x, + upars, + cov = FALSE, + total_shift = c(-0.1, -0.2), + total_scaling = c(0.7, 0.7), + total_mapping = matrix(c(1, 0.1, 0.1, 1), 2, 2), + i = 1, + log_prob_upars = log_prob_upars_test, + log_lik_i_upars = log_lik_i_upars_test, + cores = 1, + r_eff_i = 1, + is_method = "psis" + ) expect_equal_to_reference(split2, "reference-results/moment_match_split.rds") - }) test_that("passing arguments works", { - log_lik_i_upars_test_additional_argument <- function(x, upars, i, passed_arg = FALSE, ...) { + log_lik_i_upars_test_additional_argument <- function( + x, + upars, + i, + passed_arg = FALSE, + ... + ) { if (!passed_arg) { warning("passed_arg was not passed here") } - -0.5*log(2*pi) - upars[,2] - 1.0/(2*exp(upars[,2])^2)*(x$data$y[i] - upars[,1])^2 - + -0.5 * + log(2 * pi) - + upars[, 2] - + 1.0 / (2 * exp(upars[, 2])^2) * (x$data$y[i] - upars[, 1])^2 } - unconstrain_pars_test_additional_argument <- function(x, pars, passed_arg = FALSE, ...) { + unconstrain_pars_test_additional_argument <- function( + x, + pars, + passed_arg = FALSE, + ... + ) { if (!passed_arg) { warning("passed_arg was not passed here") } upars <- as.matrix(pars) - upars[,2] <- log(upars[,2]) + upars[, 2] <- log(upars[, 2]) upars } - log_prob_upars_test_additional_argument <- function(x, upars, passed_arg = FALSE, ...) { + log_prob_upars_test_additional_argument <- function( + x, + upars, + passed_arg = FALSE, + ... + ) { if (!passed_arg) { warning("passed_arg was not passed here") } - dinvchisq(exp(upars[,2])^2,x$data$n - 1,x$data$s2, log = TRUE) + - dnorm(upars[,1],x$data$ymean,exp(upars[,2])/sqrt(x$data$n), log = TRUE) + dinvchisq(exp(upars[, 2])^2, x$data$n - 1, x$data$s2, log = TRUE) + + dnorm( + upars[, 1], + x$data$ymean, + exp(upars[, 2]) / sqrt(x$data$n), + log = TRUE + ) } post_draws_test_additional_argument <- function(x, passed_arg = FALSE, ...) { if (!passed_arg) { @@ -349,18 +582,36 @@ test_that("passing arguments works", { } as.matrix(x$draws) } - log_lik_i_test_additional_argument <- function(x, i, passed_arg = FALSE, ...) { + log_lik_i_test_additional_argument <- function( + x, + i, + passed_arg = FALSE, + ... + ) { if (!passed_arg) { warning("passed_arg was not passed here") } - -0.5*log(2*pi) - log(x$draws$sigma) - 1.0/(2*x$draws$sigma^2)*(x$data$y[i] - x$draws$mu)^2 + -0.5 * + log(2 * pi) - + log(x$draws$sigma) - + 1.0 / (2 * x$draws$sigma^2) * (x$data$y[i] - x$draws$mu)^2 } # loo object loo_manual <- suppressWarnings(loo(loglik)) - expect_silent(loo_moment_match(x, loo_manual, post_draws_test_additional_argument, log_lik_i_test_additional_argument, - unconstrain_pars_test_additional_argument, log_prob_upars_test_additional_argument, - log_lik_i_upars_test_additional_argument, max_iters = 30L, - k_thres = 0.5, split = TRUE, - cov = TRUE, cores = 1, passed_arg = TRUE)) + expect_silent(loo_moment_match( + x, + loo_manual, + post_draws_test_additional_argument, + log_lik_i_test_additional_argument, + unconstrain_pars_test_additional_argument, + log_prob_upars_test_additional_argument, + log_lik_i_upars_test_additional_argument, + max_iters = 30L, + k_thres = 0.5, + split = TRUE, + cov = TRUE, + cores = 1, + passed_arg = TRUE + )) }) diff --git a/tests/testthat/test_loo_predictive_metric.R b/tests/testthat/test_loo_predictive_metric.R index cabf7b36..51de7d6a 100644 --- a/tests/testthat/test_loo_predictive_metric.R +++ b/tests/testthat/test_loo_predictive_metric.R @@ -10,43 +10,98 @@ y <- rnorm(ncol(LL)) y_binary <- rbinom(ncol(LL), 1, 0.5) mae_mean <- loo_predictive_metric(x, y, LL, metric = 'mae', r_eff = r_eff) -mae_quant <- loo_predictive_metric(x, y, LL, metric = 'mae', r_eff = r_eff, - type = 'quantile', probs = 0.9) +mae_quant <- loo_predictive_metric( + x, + y, + LL, + metric = 'mae', + r_eff = r_eff, + type = 'quantile', + probs = 0.9 +) rmse_mean <- loo_predictive_metric(x, y, LL, metric = 'rmse', r_eff = r_eff) -rmse_quant <- loo_predictive_metric(x, y, LL, metric = 'rmse', r_eff = r_eff, - type = 'quantile', probs = 0.9) +rmse_quant <- loo_predictive_metric( + x, + y, + LL, + metric = 'rmse', + r_eff = r_eff, + type = 'quantile', + probs = 0.9 +) mse_mean <- loo_predictive_metric(x, y, LL, metric = 'mse', r_eff = r_eff) -mse_quant <- loo_predictive_metric(x, y, LL, metric = 'mse', r_eff = r_eff, - type = 'quantile', probs = 0.9) +mse_quant <- loo_predictive_metric( + x, + y, + LL, + metric = 'mse', + r_eff = r_eff, + type = 'quantile', + probs = 0.9 +) -acc_mean <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'acc', r_eff = r_eff) -acc_quant <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'acc', r_eff = r_eff, - type = 'quantile', probs = 0.9) +acc_mean <- loo_predictive_metric( + x_prob, + y_binary, + LL, + metric = 'acc', + r_eff = r_eff +) +acc_quant <- loo_predictive_metric( + x_prob, + y_binary, + LL, + metric = 'acc', + r_eff = r_eff, + type = 'quantile', + probs = 0.9 +) -bacc_mean <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'balanced_acc', r_eff = r_eff) -bacc_quant <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'balanced_acc', r_eff = r_eff, - type = 'quantile', probs = 0.9) +bacc_mean <- loo_predictive_metric( + x_prob, + y_binary, + LL, + metric = 'balanced_acc', + r_eff = r_eff +) +bacc_quant <- loo_predictive_metric( + x_prob, + y_binary, + LL, + metric = 'balanced_acc', + r_eff = r_eff, + type = 'quantile', + probs = 0.9 +) test_that('loo_predictive_metric stops with incorrect inputs', { - expect_error(loo_predictive_metric(as.character(x), y, LL, r_eff = r_eff), - 'no applicable method', - fixed = TRUE) + expect_error( + loo_predictive_metric(as.character(x), y, LL, r_eff = r_eff), + 'no applicable method', + fixed = TRUE + ) - expect_error(loo_predictive_metric(x, as.character(y), LL, r_eff = r_eff), - 'is.numeric(y) is not TRUE', - fixed = TRUE) + expect_error( + loo_predictive_metric(x, as.character(y), LL, r_eff = r_eff), + 'is.numeric(y) is not TRUE', + fixed = TRUE + ) x_invalid <- matrix(rnorm(9), nrow = 3) - expect_error(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), - 'identical(ncol(x), length(y)) is not TRUE', - fixed = TRUE) + expect_error( + loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), + 'identical(ncol(x), length(y)) is not TRUE', + fixed = TRUE + ) x_invalid <- matrix(rnorm(64), nrow = 2) - expect_error(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), - 'identical(dim(x), dim(log_lik)) is not TRUE', - fixed = TRUE) + expect_error( + loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), + 'identical(dim(x), dim(log_lik)) is not TRUE', + fixed = TRUE + ) }) @@ -79,55 +134,94 @@ test_that('loo_predictive_metric return types are correct', { }) test_that('loo_predictive_metric is equal to reference', { - expect_equal_to_reference(mae_mean, 'reference-results/loo_predictive_metric_mae_mean.rds') - expect_equal_to_reference(mae_quant, 'reference-results/loo_predictive_metric_mae_quant.rds') - expect_equal_to_reference(rmse_mean, 'reference-results/loo_predictive_metric_rmse_mean.rds') - expect_equal_to_reference(rmse_quant, 'reference-results/loo_predictive_metric_rmse_quant.rds') - expect_equal_to_reference(mse_mean, 'reference-results/loo_predictive_metric_mse_mean.rds') - expect_equal_to_reference(mse_quant, 'reference-results/loo_predictive_metric_mse_quant.rds') - expect_equal_to_reference(acc_mean, 'reference-results/loo_predictive_metric_acc_mean.rds') - expect_equal_to_reference(acc_quant, 'reference-results/loo_predictive_metric_acc_quant.rds') - expect_equal_to_reference(bacc_mean, 'reference-results/loo_predictive_metric_bacc_mean.rds') - expect_equal_to_reference(bacc_quant, 'reference-results/loo_predictive_metric_bacc_quant.rds') + expect_equal_to_reference( + mae_mean, + 'reference-results/loo_predictive_metric_mae_mean.rds' + ) + expect_equal_to_reference( + mae_quant, + 'reference-results/loo_predictive_metric_mae_quant.rds' + ) + expect_equal_to_reference( + rmse_mean, + 'reference-results/loo_predictive_metric_rmse_mean.rds' + ) + expect_equal_to_reference( + rmse_quant, + 'reference-results/loo_predictive_metric_rmse_quant.rds' + ) + expect_equal_to_reference( + mse_mean, + 'reference-results/loo_predictive_metric_mse_mean.rds' + ) + expect_equal_to_reference( + mse_quant, + 'reference-results/loo_predictive_metric_mse_quant.rds' + ) + expect_equal_to_reference( + acc_mean, + 'reference-results/loo_predictive_metric_acc_mean.rds' + ) + expect_equal_to_reference( + acc_quant, + 'reference-results/loo_predictive_metric_acc_quant.rds' + ) + expect_equal_to_reference( + bacc_mean, + 'reference-results/loo_predictive_metric_bacc_mean.rds' + ) + expect_equal_to_reference( + bacc_quant, + 'reference-results/loo_predictive_metric_bacc_quant.rds' + ) }) test_that('MAE computation is correct', { expect_equal( .mae(rep(0.5, 5), rep(1, 5))$estimate, - 0.5) + 0.5 + ) expect_equal( .mae(rep(0.5, 5), rep(1, 5))$se, - 0.0) + 0.0 + ) expect_error( .mae(rep(0.5, 5), rep(1, 3)), 'length(y) == length(yhat) is not TRUE', - fixed = TRUE) + fixed = TRUE + ) }) test_that('MSE computation is correct', { expect_equal( .mse(rep(0.5, 5), rep(1, 5))$estimate, - 0.25) + 0.25 + ) expect_equal( .mse(rep(0.5, 5), rep(1, 5))$se, - 0.0) + 0.0 + ) expect_error( .mse(rep(0.5, 5), rep(1, 3)), 'length(y) == length(yhat) is not TRUE', - fixed = TRUE) + fixed = TRUE + ) }) test_that('RMSE computation is correct', { expect_equal( .rmse(rep(0.5, 5), rep(1, 5))$estimate, - sqrt(0.25)) + sqrt(0.25) + ) expect_equal( .mse(rep(0.5, 5), rep(1, 5))$se, - 0.0) + 0.0 + ) expect_error( .mse(rep(0.5, 5), rep(1, 3)), 'length(y) == length(yhat) is not TRUE', - fixed = TRUE) + fixed = TRUE + ) }) test_that('Accuracy computation is correct', { @@ -138,7 +232,8 @@ test_that('Accuracy computation is correct', { expect_error( .accuracy(c(1, 0), c(0.5)), 'length(y) == length(yhat) is not TRUE', - fixed = TRUE) + fixed = TRUE + ) expect_error( .accuracy(c(2, 1), c(0.5, 0.5)), 'all(y <= 1 & y >= 0) is not TRUE', @@ -153,13 +248,17 @@ test_that('Accuracy computation is correct', { test_that('Balanced accuracy computation is correct', { expect_equal( - .balanced_accuracy(c(0, 0, 1, 1, 1, 1), c(0.9, 0.9, 0.9, 0.9, 0.9, 0.9))$estimate, + .balanced_accuracy( + c(0, 0, 1, 1, 1, 1), + c(0.9, 0.9, 0.9, 0.9, 0.9, 0.9) + )$estimate, 0.5 ) expect_error( .balanced_accuracy(c(1, 0), c(0.5)), 'length(y) == length(yhat) is not TRUE', - fixed = TRUE) + fixed = TRUE + ) expect_error( .balanced_accuracy(c(2, 1), c(0.5, 0.5)), 'all(y <= 1 & y >= 0) is not TRUE', diff --git a/tests/testthat/test_loo_subsampling.R b/tests/testthat/test_loo_subsampling.R index 64032d0a..764a7624 100644 --- a/tests/testthat/test_loo_subsampling.R +++ b/tests/testthat/test_loo_subsampling.R @@ -5,12 +5,17 @@ context("loo_subsampling") test_that("overall loo_subampling works as expected (compared with loo) for diff_est", { set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { # each time called internally within loo the arguments will be equal to: @@ -19,63 +24,226 @@ test_that("overall loo_subampling works as expected (compared with loo) for diff dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(true_loo <- loo(llfun_test, draws = fake_posterior, data = fake_data, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + true_loo <- loo( + llfun_test, + draws = fake_posterior, + data = fake_data, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(true_loo, "psis_loo") - expect_silent(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 500, loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 500, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss, "psis_loo_ss") # Check consistency - expect_equivalent(loo_ss$pointwise[, "elpd_loo_approx"], - loo_ss$loo_subsampling$elpd_loo_approx[loo_ss$pointwise[, "idx"]]) + expect_equivalent( + loo_ss$pointwise[, "elpd_loo_approx"], + loo_ss$loo_subsampling$elpd_loo_approx[loo_ss$pointwise[, "idx"]] + ) # Expect values z <- 2 - expect_lte(loo_ss$estimates["elpd_loo", "Estimate"] - z * loo_ss$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ss$estimates["elpd_loo", "Estimate"] + z * loo_ss$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_lte(loo_ss$estimates["p_loo", "Estimate"] - z * loo_ss$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_gte(loo_ss$estimates["p_loo", "Estimate"] + z * loo_ss$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_lte(loo_ss$estimates["looic", "Estimate"] - z * loo_ss$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - expect_gte(loo_ss$estimates["looic", "Estimate"] + z * loo_ss$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - - expect_failure(expect_equal(true_loo$estimates["elpd_loo", "Estimate"], loo_ss$estimates["elpd_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["p_loo", "Estimate"], loo_ss$estimates["p_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["looic", "Estimate"], loo_ss$estimates["looic", "Estimate"], tol = 0.00000001)) + expect_lte( + loo_ss$estimates["elpd_loo", "Estimate"] - + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["elpd_loo", "Estimate"] + + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["p_loo", "Estimate"] - + z * loo_ss$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["p_loo", "Estimate"] + + z * loo_ss$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["looic", "Estimate"] - + z * loo_ss$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + expect_gte( + loo_ss$estimates["looic", "Estimate"] + + z * loo_ss$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + + expect_failure(expect_equal( + true_loo$estimates["elpd_loo", "Estimate"], + loo_ss$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["p_loo", "Estimate"], + loo_ss$estimates["p_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["looic", "Estimate"], + loo_ss$estimates["looic", "Estimate"], + tol = 0.00000001 + )) # Test that observations works as expected - expect_message(loo_ss2 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = obs_idx(loo_ss), loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) + expect_message( + loo_ss2 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = obs_idx(loo_ss), + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_equal(loo_ss2$estimates, loo_ss$estimates, tol = 0.00000001) - expect_silent(loo_ss2 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = loo_ss, loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss2 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = loo_ss, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_equal(loo_ss2$estimates, loo_ss$estimates, tol = 0.00000001) # Test lpd - expect_silent(loo_ss_lpd <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 500, loo_approximation = "lpd", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss_lpd <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 500, + loo_approximation = "lpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss_lpd, "psis_loo_ss") z <- 2 - expect_lte(loo_ss_lpd$estimates["elpd_loo", "Estimate"] - z * loo_ss_lpd$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ss_lpd$estimates["elpd_loo", "Estimate"] + z * loo_ss_lpd$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_lte(loo_ss_lpd$estimates["p_loo", "Estimate"] - z * loo_ss_lpd$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_gte(loo_ss_lpd$estimates["p_loo", "Estimate"] + z * loo_ss_lpd$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_lte(loo_ss_lpd$estimates["looic", "Estimate"] - z * loo_ss_lpd$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - expect_gte(loo_ss_lpd$estimates["looic", "Estimate"] + z * loo_ss_lpd$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - - expect_failure(expect_equal(true_loo$estimates["elpd_loo", "Estimate"], loo_ss_lpd$estimates["elpd_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["p_loo", "Estimate"], loo_ss_lpd$estimates["p_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["looic", "Estimate"], loo_ss_lpd$estimates["looic", "Estimate"], tol = 0.00000001)) - - expect_silent(loo_ss_lpd10 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 500, loo_approximation = "lpd", loo_approximation_draws = 10, r_eff = rep(1, nrow(fake_data)))) + expect_lte( + loo_ss_lpd$estimates["elpd_loo", "Estimate"] - + z * loo_ss_lpd$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ss_lpd$estimates["elpd_loo", "Estimate"] + + z * loo_ss_lpd$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_lte( + loo_ss_lpd$estimates["p_loo", "Estimate"] - + z * loo_ss_lpd$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_gte( + loo_ss_lpd$estimates["p_loo", "Estimate"] + + z * loo_ss_lpd$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_lte( + loo_ss_lpd$estimates["looic", "Estimate"] - + z * loo_ss_lpd$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + expect_gte( + loo_ss_lpd$estimates["looic", "Estimate"] + + z * loo_ss_lpd$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + + expect_failure(expect_equal( + true_loo$estimates["elpd_loo", "Estimate"], + loo_ss_lpd$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["p_loo", "Estimate"], + loo_ss_lpd$estimates["p_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["looic", "Estimate"], + loo_ss_lpd$estimates["looic", "Estimate"], + tol = 0.00000001 + )) + + expect_silent( + loo_ss_lpd10 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 500, + loo_approximation = "lpd", + loo_approximation_draws = 10, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss_lpd10, "psis_loo_ss") z <- 2 - expect_lte(loo_ss_lpd10$estimates["elpd_loo", "Estimate"] - z * loo_ss_lpd10$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ss_lpd10$estimates["elpd_loo", "Estimate"] + z * loo_ss_lpd10$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_lte(loo_ss_lpd10$estimates["p_loo", "Estimate"] - z * loo_ss_lpd10$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_gte(loo_ss_lpd10$estimates["p_loo", "Estimate"] + z * loo_ss_lpd10$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_lte(loo_ss_lpd10$estimates["looic", "Estimate"] - z * loo_ss_lpd10$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - expect_gte(loo_ss_lpd10$estimates["looic", "Estimate"] + z * loo_ss_lpd10$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - - expect_failure(expect_equal(true_loo$estimates["elpd_loo", "Estimate"], loo_ss_lpd10$estimates["elpd_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["p_loo", "Estimate"], loo_ss_lpd10$estimates["p_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["looic", "Estimate"], loo_ss_lpd10$estimates["looic", "Estimate"], tol = 0.00000001)) + expect_lte( + loo_ss_lpd10$estimates["elpd_loo", "Estimate"] - + z * loo_ss_lpd10$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ss_lpd10$estimates["elpd_loo", "Estimate"] + + z * loo_ss_lpd10$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_lte( + loo_ss_lpd10$estimates["p_loo", "Estimate"] - + z * loo_ss_lpd10$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_gte( + loo_ss_lpd10$estimates["p_loo", "Estimate"] + + z * loo_ss_lpd10$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_lte( + loo_ss_lpd10$estimates["looic", "Estimate"] - + z * loo_ss_lpd10$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + expect_gte( + loo_ss_lpd10$estimates["looic", "Estimate"] + + z * loo_ss_lpd10$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + + expect_failure(expect_equal( + true_loo$estimates["elpd_loo", "Estimate"], + loo_ss_lpd10$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["p_loo", "Estimate"], + loo_ss_lpd10$estimates["p_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["looic", "Estimate"], + loo_ss_lpd10$estimates["looic", "Estimate"], + tol = 0.00000001 + )) # Test conversion of objects expect_silent(true_loo_2 <- loo:::as.psis_loo.psis_loo(true_loo)) @@ -85,261 +253,651 @@ test_that("overall loo_subampling works as expected (compared with loo) for diff expect_failure(expect_s3_class(true_loo_conv, "psis_loo_ss")) expect_equal(true_loo_conv, true_loo) expect_error(loo:::as.psis_loo.psis_loo_ss(loo_ss)) - }) test_that("loo with subsampling of all observations works as ordinary loo.", { set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(true_loo <- loo(llfun_test, draws = fake_posterior, data = fake_data, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + true_loo <- loo( + llfun_test, + draws = fake_posterior, + data = fake_data, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(true_loo, "psis_loo") - expect_silent(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 1000, loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 1000, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss, "psis_loo_ss") - expect_error(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 1001, loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) - - expect_equal(true_loo$estimates["elpd_loo", "Estimate"], loo_ss$estimates["elpd_loo", "Estimate"], tol = 0.00000001) - expect_equal(true_loo$estimates["p_loo", "Estimate"], loo_ss$estimates["p_loo", "Estimate"], tol = 0.00000001) - expect_equal(true_loo$estimates["looic", "Estimate"], loo_ss$estimates["looic", "Estimate"], tol = 0.00000001) - - expect_equal(dim(true_loo),dim(loo_ss)) + expect_error( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 1001, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) + + expect_equal( + true_loo$estimates["elpd_loo", "Estimate"], + loo_ss$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + ) + expect_equal( + true_loo$estimates["p_loo", "Estimate"], + loo_ss$estimates["p_loo", "Estimate"], + tol = 0.00000001 + ) + expect_equal( + true_loo$estimates["looic", "Estimate"], + loo_ss$estimates["looic", "Estimate"], + tol = 0.00000001 + ) + + expect_equal(dim(true_loo), dim(loo_ss)) expect_equal(true_loo$diagnostics, loo_ss$diagnostics) expect_equal(max(loo_ss$pointwise[, "m_i"]), 1) - }) test_that("overall loo_subsample works with diff_srs as expected (compared with loo)", { set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(true_loo <- loo(x = llfun_test, draws = fake_posterior, data = fake_data, r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 200, loo_approximation = "plpd", estimator = "diff_srs", r_eff = rep(1, nrow(fake_data)))) - expect_equal(true_loo$estimates[1,1], loo_ss$estimates[1,1], tol = 0.1) - + expect_silent( + true_loo <- loo( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 200, + loo_approximation = "plpd", + estimator = "diff_srs", + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_equal(true_loo$estimates[1, 1], loo_ss$estimates[1, 1], tol = 0.1) }) test_that("Test the srs estimator with 'none' approximation", { set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(true_loo <- loo(llfun_test, draws = fake_posterior, data = fake_data, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + true_loo <- loo( + llfun_test, + draws = fake_posterior, + data = fake_data, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(true_loo, "psis_loo") - expect_silent(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 200, loo_approximation = "none", estimator = "srs", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 200, + loo_approximation = "none", + estimator = "srs", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss, "psis_loo_ss") - expect_error(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 1100, loo_approximation = "none", estimator = "srs", r_eff = rep(1, nrow(fake_data)))) + expect_error( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 1100, + loo_approximation = "none", + estimator = "srs", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_equal(length(obs_idx(loo_ss)), nobs(loo_ss)) - # Check consistency - expect_equivalent(loo_ss$pointwise[, "elpd_loo_approx"], - loo_ss$loo_subsampling$elpd_loo_approx[loo_ss$pointwise[, "idx"]]) + expect_equivalent( + loo_ss$pointwise[, "elpd_loo_approx"], + loo_ss$loo_subsampling$elpd_loo_approx[loo_ss$pointwise[, "idx"]] + ) # Expect values z <- 2 - expect_lte(loo_ss$estimates["elpd_loo", "Estimate"] - z * loo_ss$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ss$estimates["elpd_loo", "Estimate"] + z * loo_ss$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_lte(loo_ss$estimates["p_loo", "Estimate"] - z * loo_ss$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_gte(loo_ss$estimates["p_loo", "Estimate"] + z * loo_ss$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_lte(loo_ss$estimates["looic", "Estimate"] - z * loo_ss$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - expect_gte(loo_ss$estimates["looic", "Estimate"] + z * loo_ss$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - - expect_failure(expect_equal(true_loo$estimates["elpd_loo", "Estimate"], loo_ss$estimates["elpd_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["p_loo", "Estimate"], loo_ss$estimates["p_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["looic", "Estimate"], loo_ss$estimates["looic", "Estimate"], tol = 0.00000001)) - + expect_lte( + loo_ss$estimates["elpd_loo", "Estimate"] - + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["elpd_loo", "Estimate"] + + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["p_loo", "Estimate"] - + z * loo_ss$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["p_loo", "Estimate"] + + z * loo_ss$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["looic", "Estimate"] - + z * loo_ss$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + expect_gte( + loo_ss$estimates["looic", "Estimate"] + + z * loo_ss$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + + expect_failure(expect_equal( + true_loo$estimates["elpd_loo", "Estimate"], + loo_ss$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["p_loo", "Estimate"], + loo_ss$estimates["p_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["looic", "Estimate"], + loo_ss$estimates["looic", "Estimate"], + tol = 0.00000001 + )) }) test_that("Test the Hansen-Hurwitz estimator", { set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(true_loo <- loo(llfun_test, draws = fake_posterior, data = fake_data, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + true_loo <- loo( + llfun_test, + draws = fake_posterior, + data = fake_data, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(true_loo, "psis_loo") - expect_silent(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 300, loo_approximation = "plpd", estimator = "hh_pps", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 300, + loo_approximation = "plpd", + estimator = "hh_pps", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss, "psis_loo_ss") - expect_silent(loo_ss_max <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 1100, loo_approximation = "plpd", estimator = "hh_pps", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss_max <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 1100, + loo_approximation = "plpd", + estimator = "hh_pps", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss_max, "psis_loo_ss") - expect_silent(loo_ss_max2 <- update(loo_ss, draws = fake_posterior, data = fake_data, observations = 1100, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss_max2 <- update( + loo_ss, + draws = fake_posterior, + data = fake_data, + observations = 1100, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_equal(nobs(loo_ss_max2), 1100) expect_gt(max(loo_ss_max2$pointwise[, "m_i"]), 1) - expect_error(loo_ss_max2 <- update(loo_ss_max2, draws = fake_posterior, data = fake_data, observations = 300, r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_max3 <- update(loo_ss, draws = fake_posterior, data = fake_data, observations = 1500, r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss2 <- update(loo_ss, draws = fake_posterior, data = fake_data, observations = loo_ss, r_eff = rep(1, nrow(fake_data)))) - expect_error(loo_ss2 <- update(loo_ss, draws = fake_posterior, data = fake_data, observations = loo_ss, loo_approximation = "lpd", r_eff = rep(1, nrow(fake_data)))) + expect_error( + loo_ss_max2 <- update( + loo_ss_max2, + draws = fake_posterior, + data = fake_data, + observations = 300, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_max3 <- update( + loo_ss, + draws = fake_posterior, + data = fake_data, + observations = 1500, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss2 <- update( + loo_ss, + draws = fake_posterior, + data = fake_data, + observations = loo_ss, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_error( + loo_ss2 <- update( + loo_ss, + draws = fake_posterior, + data = fake_data, + observations = loo_ss, + loo_approximation = "lpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_equal(loo_ss$estimates, loo_ss2$estimates) expect_equal(length(obs_idx(loo_ss_max)), length(obs_idx(loo_ss_max2))) expect_equal(length(obs_idx(loo_ss_max)), nobs(loo_ss_max)) - # Check consistency - expect_equivalent(loo_ss$pointwise[, "elpd_loo_approx"], - loo_ss$loo_subsampling$elpd_loo_approx[loo_ss$pointwise[, "idx"]]) + expect_equivalent( + loo_ss$pointwise[, "elpd_loo_approx"], + loo_ss$loo_subsampling$elpd_loo_approx[loo_ss$pointwise[, "idx"]] + ) # Check consistency - expect_equivalent(loo_ss_max$pointwise[, "elpd_loo_approx"], - loo_ss_max$loo_subsampling$elpd_loo_approx[loo_ss_max$pointwise[, "idx"]]) + expect_equivalent( + loo_ss_max$pointwise[, "elpd_loo_approx"], + loo_ss_max$loo_subsampling$elpd_loo_approx[loo_ss_max$pointwise[, "idx"]] + ) # Expect values z <- 2 - expect_lte(loo_ss$estimates["elpd_loo", "Estimate"] - z * loo_ss$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ss$estimates["elpd_loo", "Estimate"] + z * loo_ss$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_lte(loo_ss$estimates["p_loo", "Estimate"] - z * loo_ss$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_gte(loo_ss$estimates["p_loo", "Estimate"] + z * loo_ss$estimates["p_loo", "subsampling SE"], true_loo$estimates["p_loo", "Estimate"]) - expect_lte(loo_ss$estimates["looic", "Estimate"] - z * loo_ss$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - expect_gte(loo_ss$estimates["looic", "Estimate"] + z * loo_ss$estimates["looic", "subsampling SE"], true_loo$estimates["looic", "Estimate"]) - - expect_failure(expect_equal(true_loo$estimates["elpd_loo", "Estimate"], loo_ss$estimates["elpd_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["p_loo", "Estimate"], loo_ss$estimates["p_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(true_loo$estimates["looic", "Estimate"], loo_ss$estimates["looic", "Estimate"], tol = 0.00000001)) - - expect_lte(loo_ss_max$estimates["elpd_loo", "Estimate"] - z * loo_ss_max$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ss_max$estimates["elpd_loo", "Estimate"] + z * loo_ss_max$estimates["elpd_loo", "subsampling SE"], true_loo$estimates["elpd_loo", "Estimate"]) - + expect_lte( + loo_ss$estimates["elpd_loo", "Estimate"] - + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["elpd_loo", "Estimate"] + + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["p_loo", "Estimate"] - + z * loo_ss$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["p_loo", "Estimate"] + + z * loo_ss$estimates["p_loo", "subsampling SE"], + true_loo$estimates["p_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["looic", "Estimate"] - + z * loo_ss$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + expect_gte( + loo_ss$estimates["looic", "Estimate"] + + z * loo_ss$estimates["looic", "subsampling SE"], + true_loo$estimates["looic", "Estimate"] + ) + + expect_failure(expect_equal( + true_loo$estimates["elpd_loo", "Estimate"], + loo_ss$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["p_loo", "Estimate"], + loo_ss$estimates["p_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + true_loo$estimates["looic", "Estimate"], + loo_ss$estimates["looic", "Estimate"], + tol = 0.00000001 + )) + + expect_lte( + loo_ss_max$estimates["elpd_loo", "Estimate"] - + z * loo_ss_max$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ss_max$estimates["elpd_loo", "Estimate"] + + z * loo_ss_max$estimates["elpd_loo", "subsampling SE"], + true_loo$estimates["elpd_loo", "Estimate"] + ) }) test_that("update.psis_loo_ss works as expected (compared with loo)", { - - set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(true_loo <- loo(llfun_test, draws = fake_posterior, data = fake_data, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + true_loo <- loo( + llfun_test, + draws = fake_posterior, + data = fake_data, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(true_loo, "psis_loo") - expect_silent(loo_ss <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 500, loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 500, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_s3_class(loo_ss, "psis_loo_ss") # Check error when draws and data dimensions differ - expect_error(loo_ss2 <- update(object = loo_ss, draws = cbind(fake_posterior, 1), data = fake_data, observations = 600, r_eff = rep(1, nrow(fake_data)))) - expect_error(loo_ss2 <- update(object = loo_ss, draws = fake_posterior, data = fake_data[-1,], observations = 600, r_eff = rep(1, nrow(fake_data)))) + expect_error( + loo_ss2 <- update( + object = loo_ss, + draws = cbind(fake_posterior, 1), + data = fake_data, + observations = 600, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_error( + loo_ss2 <- update( + object = loo_ss, + draws = fake_posterior, + data = fake_data[-1, ], + observations = 600, + r_eff = rep(1, nrow(fake_data)) + ) + ) # Add tests for adding observations - expect_silent(loo_ss2 <- update(object = loo_ss, draws = fake_posterior, data = fake_data, observations = 600, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss2 <- update( + object = loo_ss, + draws = fake_posterior, + data = fake_data, + observations = 600, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_equal(dim(loo_ss2)[2] - dim(loo_ss)[2], expected = 100) expect_equal(dim(loo_ss2)[2], expected = dim(loo_ss2$pointwise)[1]) expect_length(loo_ss2$diagnostics$pareto_k, 600) expect_length(loo_ss2$diagnostics$n_eff, 600) - for(i in 1:nrow(loo_ss2$estimates)) { - expect_lt(loo_ss2$estimates[i, "subsampling SE"], - loo_ss$estimates[i, "subsampling SE"]) + for (i in 1:nrow(loo_ss2$estimates)) { + expect_lt( + loo_ss2$estimates[i, "subsampling SE"], + loo_ss$estimates[i, "subsampling SE"] + ) } - expect_silent(loo_ss2b <- update(object = loo_ss, draws = fake_posterior, data = fake_data)) + expect_silent( + loo_ss2b <- update( + object = loo_ss, + draws = fake_posterior, + data = fake_data + ) + ) expect_equal(loo_ss2b$estimates, loo_ss$estimates) expect_equal(loo_ss2b$pointwise, loo_ss$pointwise) expect_equal(loo_ss2b$diagnostics$pareto_k, loo_ss$diagnostics$pareto_k) expect_equal(loo_ss2b$diagnostics$n_eff, loo_ss$diagnostics$n_eff) - expect_silent(loo_ss3 <- update(object = loo_ss2, draws = fake_posterior, data = fake_data, observations = loo_ss)) + expect_silent( + loo_ss3 <- update( + object = loo_ss2, + draws = fake_posterior, + data = fake_data, + observations = loo_ss + ) + ) expect_equal(loo_ss3$estimates, loo_ss$estimates) expect_equal(loo_ss3$pointwise, loo_ss$pointwise) expect_equal(loo_ss3$diagnostics$pareto_k, loo_ss$diagnostics$pareto_k) expect_equal(loo_ss3$diagnostics$n_eff, loo_ss$diagnostics$n_eff) - expect_silent(loo_ss4 <- update(object = loo_ss, draws = fake_posterior, data = fake_data, observations = 1000, r_eff = rep(1, nrow(fake_data)))) - expect_equal(loo_ss4$estimates[,1], true_loo$estimates[,1]) - expect_equal(loo_ss4$estimates[,2], true_loo$estimates[,2], tol = 0.001) - - expect_silent(loo_ss5 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 1000, loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss4 <- update( + object = loo_ss, + draws = fake_posterior, + data = fake_data, + observations = 1000, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_equal(loo_ss4$estimates[, 1], true_loo$estimates[, 1]) + expect_equal(loo_ss4$estimates[, 2], true_loo$estimates[, 2], tol = 0.001) + + expect_silent( + loo_ss5 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 1000, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) ss4_order <- order(loo_ss4$pointwise[, "idx"]) - expect_equal(loo_ss4$pointwise[ss4_order,c(1,3,4)], loo_ss5$pointwise[,c(1,3,4)]) - expect_equal(loo_ss4$diagnostics$pareto_k[ss4_order], loo_ss5$diagnostics$pareto_k) + expect_equal( + loo_ss4$pointwise[ss4_order, c(1, 3, 4)], + loo_ss5$pointwise[, c(1, 3, 4)] + ) + expect_equal( + loo_ss4$diagnostics$pareto_k[ss4_order], + loo_ss5$diagnostics$pareto_k + ) expect_equal(loo_ss4$diagnostics$n_eff[ss4_order], loo_ss5$diagnostics$n_eff) - expect_equal(loo_ss4$pointwise[ss4_order,c(1,3,4)], true_loo$pointwise[,c(1,3,4)]) - expect_equal(loo_ss4$diagnostics$pareto_k[ss4_order], true_loo$diagnostics$pareto_k) + expect_equal( + loo_ss4$pointwise[ss4_order, c(1, 3, 4)], + true_loo$pointwise[, c(1, 3, 4)] + ) + expect_equal( + loo_ss4$diagnostics$pareto_k[ss4_order], + true_loo$diagnostics$pareto_k + ) expect_equal(loo_ss4$diagnostics$n_eff[ss4_order], true_loo$diagnostics$n_eff) - expect_error(loo_ss_min <- update(object = loo_ss, draws = fake_posterior, data = fake_data, observations = 50, r_eff = rep(1, nrow(fake_data)))) + expect_error( + loo_ss_min <- update( + object = loo_ss, + draws = fake_posterior, + data = fake_data, + observations = 50, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_silent(true_loo_ss <- loo:::as.psis_loo_ss.psis_loo(true_loo)) - expect_silent(loo_ss_subset0 <- update(true_loo_ss, observations = loo_ss, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss_subset0 <- update( + true_loo_ss, + observations = loo_ss, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_true(identical(obs_idx(loo_ss_subset0), obs_idx(loo_ss))) - expect_silent(loo_ss_subset1 <- update(object = loo_ss, observations = loo_ss, r_eff = rep(1, nrow(fake_data)))) - expect_message(loo_ss_subset2 <- update(object = loo_ss, observations = obs_idx(loo_ss)[1:10], r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss_subset1 <- update( + object = loo_ss, + observations = loo_ss, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_message( + loo_ss_subset2 <- update( + object = loo_ss, + observations = obs_idx(loo_ss)[1:10], + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_equal(nobs(loo_ss_subset2), 10) - expect_silent(true_loo_ss <- loo:::as.psis_loo_ss.psis_loo(true_loo)) set.seed(4711) - expect_silent(loo_ss2 <- update(object = loo_ss, draws = fake_posterior, data = fake_data, observations = 600, r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss2_subset0 <- update(object = true_loo_ss, observations = loo_ss2, r_eff = rep(1, nrow(fake_data)))) + expect_silent( + loo_ss2 <- update( + object = loo_ss, + draws = fake_posterior, + data = fake_data, + observations = 600, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss2_subset0 <- update( + object = true_loo_ss, + observations = loo_ss2, + r_eff = rep(1, nrow(fake_data)) + ) + ) expect_true(setequal(obs_idx(loo_ss2), obs_idx(loo_ss2_subset0))) expect_true(identical(obs_idx(loo_ss2), obs_idx(loo_ss2_subset0))) expect_true(identical(loo_ss2$diagnostic, loo_ss2_subset0$diagnostic)) # Add tests for changing approx variable - expect_silent(loo_ss_lpd <- update(object = loo_ss, draws = fake_posterior, data = fake_data, loo_approximation = "lpd", r_eff = rep(1, nrow(fake_data)))) - expect_failure(expect_equal(loo_ss_lpd$loo_subsampling$elpd_loo_approx, loo_ss$loo_subsampling$elpd_loo_approx)) + expect_silent( + loo_ss_lpd <- update( + object = loo_ss, + draws = fake_posterior, + data = fake_data, + loo_approximation = "lpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_failure(expect_equal( + loo_ss_lpd$loo_subsampling$elpd_loo_approx, + loo_ss$loo_subsampling$elpd_loo_approx + )) expect_equal(dim(loo_ss_lpd)[2], dim(loo_ss)[2]) expect_equal(dim(loo_ss_lpd)[2], dim(loo_ss_lpd$pointwise)[1]) expect_length(loo_ss_lpd$diagnostics$pareto_k, 500) expect_length(loo_ss_lpd$diagnostics$n_eff, 500) - expect_failure(expect_equal(loo_ss_lpd$estimates[1, "subsampling SE"], loo_ss$estimates[1, "subsampling SE"])) - expect_failure(expect_equal(loo_ss_lpd$estimates[3, "subsampling SE"], loo_ss$estimates[3, "subsampling SE"])) - + expect_failure(expect_equal( + loo_ss_lpd$estimates[1, "subsampling SE"], + loo_ss$estimates[1, "subsampling SE"] + )) + expect_failure(expect_equal( + loo_ss_lpd$estimates[3, "subsampling SE"], + loo_ss$estimates[3, "subsampling SE"] + )) }) - - - - - context("loo_subsampling_approximations") geterate_test_elpd_dataset <- function() { - N <- 10; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 10 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- draws <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) list(fake_posterior = fake_posterior, fake_data = fake_data) @@ -356,37 +914,78 @@ test_elpd_loo_approximation <- function(cores) { } # Compute plpd approximation - expect_silent(pi_vals <- loo:::elpd_loo_approximation(.llfun = llfun_test, data = fake_data, draws = fake_posterior, loo_approximation = "plpd", cores = cores)) + expect_silent( + pi_vals <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior, + loo_approximation = "plpd", + cores = cores + ) + ) # Compute it manually point <- mean(fake_posterior) llik <- dbinom(fake_data$y, size = fake_data$K, prob = point, log = TRUE) abs_lliks <- abs(llik) - man_elpd_loo_approximation <- abs_lliks/sum(abs_lliks) - expect_equal(abs(pi_vals)/sum(abs(pi_vals)), man_elpd_loo_approximation, tol = 0.00001) + man_elpd_loo_approximation <- abs_lliks / sum(abs_lliks) + expect_equal( + abs(pi_vals) / sum(abs(pi_vals)), + man_elpd_loo_approximation, + tol = 0.00001 + ) # Compute lpd approximation - expect_silent(pi_vals <- loo:::elpd_loo_approximation(.llfun = llfun_test, data = fake_data, draws = fake_posterior, loo_approximation = "lpd", cores = cores)) + expect_silent( + pi_vals <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior, + loo_approximation = "lpd", + cores = cores + ) + ) # Compute it manually llik <- numeric(10) - for(i in seq_along(fake_data$y)){ - llik[i] <- loo:::logMeanExp(dbinom(fake_data$y[i], size = fake_data$K, prob = fake_posterior, log = TRUE)) + for (i in seq_along(fake_data$y)) { + llik[i] <- loo:::logMeanExp(dbinom( + fake_data$y[i], + size = fake_data$K, + prob = fake_posterior, + log = TRUE + )) } abs_lliks <- abs(llik) - man_approx_loo_variable <- abs_lliks/sum(abs_lliks) - expect_equal(abs(pi_vals)/sum(abs(pi_vals)), man_approx_loo_variable, tol = 0.00001) + man_approx_loo_variable <- abs_lliks / sum(abs_lliks) + expect_equal( + abs(pi_vals) / sum(abs(pi_vals)), + man_approx_loo_variable, + tol = 0.00001 + ) # Compute waic approximation - expect_silent(pi_vals_waic <- loo:::elpd_loo_approximation(.llfun = llfun_test, data = fake_data, draws = fake_posterior, loo_approximation = "waic", cores = cores)) + expect_silent( + pi_vals_waic <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior, + loo_approximation = "waic", + cores = cores + ) + ) expect_true(all(pi_vals > pi_vals_waic)) expect_true(sum(pi_vals) - sum(pi_vals_waic) < 1) # Compute tis approximation - expect_silent(pi_vals_tis <- loo:::elpd_loo_approximation(.llfun = llfun_test, - data = fake_data, - draws = fake_posterior, - loo_approximation = "tis", - loo_approximation_draws = 100, - cores = cores)) + expect_silent( + pi_vals_tis <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior, + loo_approximation = "tis", + loo_approximation_draws = 100, + cores = cores + ) + ) expect_true(all(pi_vals > pi_vals_tis)) expect_true(sum(pi_vals) - sum(pi_vals_tis) < 1) } @@ -400,59 +999,156 @@ test_that("elpd_loo_approximation with multiple cores", { }) test_that("Test loo_approximation_draws", { - - set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- draws <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(res1 <- loo:::elpd_loo_approximation(.llfun = llfun_test, data = fake_data, draws = fake_posterior, loo_approximation = "waic", loo_approximation_draws = NULL, cores = 1)) - expect_silent(res2 <- loo:::elpd_loo_approximation(.llfun = llfun_test, data = fake_data, draws = fake_posterior, loo_approximation = "waic", loo_approximation_draws = 10, cores = 1)) - expect_silent(res3 <- loo:::elpd_loo_approximation(.llfun = llfun_test, data = fake_data, draws = fake_posterior[1:10*100,], loo_approximation = "waic", loo_approximation_draws = NULL, cores = 1)) - expect_silent(res4 <- loo:::elpd_loo_approximation(.llfun = llfun_test, data = fake_data, draws = fake_posterior[1:10*100,, drop = FALSE], loo_approximation = "waic", loo_approximation_draws = NULL, cores = 1)) + expect_silent( + res1 <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior, + loo_approximation = "waic", + loo_approximation_draws = NULL, + cores = 1 + ) + ) + expect_silent( + res2 <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior, + loo_approximation = "waic", + loo_approximation_draws = 10, + cores = 1 + ) + ) + expect_silent( + res3 <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior[1:10 * 100, ], + loo_approximation = "waic", + loo_approximation_draws = NULL, + cores = 1 + ) + ) + expect_silent( + res4 <- loo:::elpd_loo_approximation( + .llfun = llfun_test, + data = fake_data, + draws = fake_posterior[1:10 * 100, , drop = FALSE], + loo_approximation = "waic", + loo_approximation_draws = NULL, + cores = 1 + ) + ) expect_failure(expect_equal(res1, res3)) expect_equal(res2, res3) - expect_silent(loo_ss1 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 100, loo_approximation = "plpd", r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss2 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 100, loo_approximation = "plpd", loo_approximation_draws = 10, r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss3 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 100, loo_approximation = "plpd", loo_approximation_draws = 31, r_eff = rep(1, nrow(fake_data)))) - expect_error(loo_ss4 <- loo_subsample(x = llfun_test, draws = fake_posterior, data = fake_data, observations = 100, loo_approximation = "plpd", loo_approximation_draws = 3100, r_eff = rep(1, nrow(fake_data)))) - - expect_equal(names(loo_ss1$loo_subsampling), c("elpd_loo_approx", "loo_approximation", "loo_approximation_draws", "estimator", ".llfun", ".llgrad", ".llhess", "data_dim", "ndraws")) + expect_silent( + loo_ss1 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss2 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "plpd", + loo_approximation_draws = 10, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss3 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "plpd", + loo_approximation_draws = 31, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_error( + loo_ss4 <- loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "plpd", + loo_approximation_draws = 3100, + r_eff = rep(1, nrow(fake_data)) + ) + ) + + expect_equal( + names(loo_ss1$loo_subsampling), + c( + "elpd_loo_approx", + "loo_approximation", + "loo_approximation_draws", + "estimator", + ".llfun", + ".llgrad", + ".llhess", + "data_dim", + "ndraws" + ) + ) expect_null(loo_ss1$loo_subsampling$loo_approximation_draws) expect_equal(loo_ss2$loo_subsampling$loo_approximation_draws, 10L) expect_equal(loo_ss3$loo_subsampling$loo_approximation_draws, 31L) - }) - test_that("waic using delta method and gradient", { - - - if (FALSE){ + if (FALSE) { # Code to generate testdata - saved and loaded to avoid dependency of mvtnorm set.seed(123) - N <- 400; beta <- c(1,2); X_full <- matrix(rep(1,N), ncol = 1); X_full <- cbind(X_full, runif(N)); S <- 1000 - y_full <- rnorm(n = N, mean = X_full%*%beta, sd = 1) - X <- X_full; y <- y_full - Lambda_0 <- diag(length(beta)); mu_0 <- c(0,0) - b_hat <- solve(t(X)%*%X)%*%t(X)%*%y - mu_n <- solve(t(X)%*%X)%*%(t(X)%*%X%*%b_hat + Lambda_0%*%mu_0) - Lambda_n <- t(X)%*%X + Lambda_0 + N <- 400 + beta <- c(1, 2) + X_full <- matrix(rep(1, N), ncol = 1) + X_full <- cbind(X_full, runif(N)) + S <- 1000 + y_full <- rnorm(n = N, mean = X_full %*% beta, sd = 1) + X <- X_full + y <- y_full + Lambda_0 <- diag(length(beta)) + mu_0 <- c(0, 0) + b_hat <- solve(t(X) %*% X) %*% t(X) %*% y + mu_n <- solve(t(X) %*% X) %*% (t(X) %*% X %*% b_hat + Lambda_0 %*% mu_0) + Lambda_n <- t(X) %*% X + Lambda_0 # Uncomment row below when running. Commented out to remove CHECK warnings # fake_posterior <- mvtnorm::rmvnorm(n = S, mean = mu_n, sigma = solve(Lambda_n)) colnames(fake_posterior) <- c("a", "b") fake_data <- data.frame(y, X) - save(fake_posterior, fake_data, file = test_path("data-for-tests/normal_reg_waic_test_example.rda")) + save( + fake_posterior, + fake_data, + file = test_path("data-for-tests/normal_reg_waic_test_example.rda") + ) } else { load(file = test_path("data-for-tests/normal_reg_waic_test_example.rda")) } @@ -460,53 +1156,148 @@ test_that("waic using delta method and gradient", { .llfun <- function(data_i, draws) { # data_i: ith row of fdata (fake_data[i,, drop=FALSE]) # draws: entire fake_posterior matrix - dnorm(data_i$y, mean = draws[, c("a", "b")] %*% t(as.matrix(data_i[, c("X1", "X2")])), sd = 1, log = TRUE) + dnorm( + data_i$y, + mean = draws[, c("a", "b")] %*% t(as.matrix(data_i[, c("X1", "X2")])), + sd = 1, + log = TRUE + ) } .llgrad <- function(data_i, draws) { x_i <- data_i[, "X2"] - gr <- cbind(data_i$y - draws[,"a"] - draws[,"b"]*x_i, - (data_i$y - draws[,"a"] - draws[,"b"]*x_i) * x_i) + gr <- cbind( + data_i$y - draws[, "a"] - draws[, "b"] * x_i, + (data_i$y - draws[, "a"] - draws[, "b"] * x_i) * x_i + ) colnames(gr) <- c("a", "b") gr } fake_posterior <- cbind(fake_posterior, runif(nrow(fake_posterior))) - expect_silent(approx_loo_waic <- loo:::elpd_loo_approximation(.llfun, data = fake_data, draws = fake_posterior, cores = 1, loo_approximation = "waic")) - expect_silent(approx_loo_waic_delta <- loo:::elpd_loo_approximation(.llfun, data = fake_data, draws = fake_posterior, cores = 1, loo_approximation = "waic_grad", .llgrad = .llgrad)) - expect_silent(approx_loo_waic_delta_diag <- loo:::elpd_loo_approximation(.llfun, data = fake_data, draws = fake_posterior, cores = 1, loo_approximation = "waic_grad_marginal", .llgrad = .llgrad)) + expect_silent( + approx_loo_waic <- loo:::elpd_loo_approximation( + .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + loo_approximation = "waic" + ) + ) + expect_silent( + approx_loo_waic_delta <- loo:::elpd_loo_approximation( + .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + loo_approximation = "waic_grad", + .llgrad = .llgrad + ) + ) + expect_silent( + approx_loo_waic_delta_diag <- loo:::elpd_loo_approximation( + .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + loo_approximation = "waic_grad_marginal", + .llgrad = .llgrad + ) + ) # Test that the approaches should not deviate too much diff_waic_delta <- mean(approx_loo_waic - approx_loo_waic_delta) diff_waic_delta_diag <- mean(approx_loo_waic - approx_loo_waic_delta_diag) - expect_equal(approx_loo_waic,approx_loo_waic_delta_diag, tol = 0.1) - expect_equal(approx_loo_waic,approx_loo_waic_delta, tol = 0.01) + expect_equal(approx_loo_waic, approx_loo_waic_delta_diag, tol = 0.1) + expect_equal(approx_loo_waic, approx_loo_waic_delta, tol = 0.01) # Test usage in subsampling_loo - expect_silent(loo_ss_waic <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic", observations = 50, llgrad = .llgrad)) - expect_silent(loo_ss_waic_delta <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic_grad", observations = 50, llgrad = .llgrad)) - expect_silent(loo_ss_waic_delta_marginal <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic_grad_marginal", observations = 50, llgrad = .llgrad)) - expect_silent(loo_ss_plpd <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "plpd", observations = 50, llgrad = .llgrad)) - expect_error(loo_ss_waic_delta <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic_grad", observations = 50)) + expect_silent( + loo_ss_waic <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic", + observations = 50, + llgrad = .llgrad + ) + ) + expect_silent( + loo_ss_waic_delta <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic_grad", + observations = 50, + llgrad = .llgrad + ) + ) + expect_silent( + loo_ss_waic_delta_marginal <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic_grad_marginal", + observations = 50, + llgrad = .llgrad + ) + ) + expect_silent( + loo_ss_plpd <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "plpd", + observations = 50, + llgrad = .llgrad + ) + ) + expect_error( + loo_ss_waic_delta <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic_grad", + observations = 50 + ) + ) }) test_that("waic using delta 2nd order method", { - - - if (FALSE){ + if (FALSE) { # Code to generate testdata - saved and loaded to avoid dependency of MCMCPack set.seed(123) - N <- 100; beta <- c(1,2); X_full <- matrix(rep(1,N), ncol = 1); X_full <- cbind(X_full, runif(N)); S <- 1000 - y_full <- rnorm(n = N, mean = X_full%*%beta, sd = 0.5) - X <- X_full; y <- y_full + N <- 100 + beta <- c(1, 2) + X_full <- matrix(rep(1, N), ncol = 1) + X_full <- cbind(X_full, runif(N)) + S <- 1000 + y_full <- rnorm(n = N, mean = X_full %*% beta, sd = 0.5) + X <- X_full + y <- y_full # Uncomment row below when running. Commented out to remove CHECK warnings # fake_posterior <- MCMCpack::MCMCregress(y~x, data = data.frame(y = y,x=X[,2]), thin = 10, mcmc = 10000) # Because Im lazy fake_posterior <- as.matrix(fake_posterior) - fake_posterior[,"sigma2"] <- sqrt(fake_posterior[,"sigma2"]) + fake_posterior[, "sigma2"] <- sqrt(fake_posterior[, "sigma2"]) colnames(fake_posterior) <- c("a", "b", "sigma") fake_data <- data.frame(y, X) - save(fake_posterior, fake_data, file = test_path("data-for-tests/normal_reg_waic_test_example2.rda"), compression_level = 9) + save( + fake_posterior, + fake_data, + file = test_path("data-for-tests/normal_reg_waic_test_example2.rda"), + compression_level = 9 + ) } else { load(file = test_path("data-for-tests/normal_reg_waic_test_example2.rda")) } @@ -514,40 +1305,51 @@ test_that("waic using delta 2nd order method", { .llfun <- function(data_i, draws) { # data_i: ith row of fdata (data_i <- fake_data[i,, drop=FALSE]) # draws: entire fake_posterior matrix - dnorm(data_i$y, mean = draws[, c("a", "b")] %*% t(as.matrix(data_i[, c("X1", "X2")])), sd = draws[, c("sigma")], log = TRUE) + dnorm( + data_i$y, + mean = draws[, c("a", "b")] %*% t(as.matrix(data_i[, c("X1", "X2")])), + sd = draws[, c("sigma")], + log = TRUE + ) } .llgrad <- function(data_i, draws) { - sigma <- draws[,"sigma"] + sigma <- draws[, "sigma"] sigma2 <- sigma^2 - b <- draws[,"b"] - a <- draws[,"a"] + b <- draws[, "b"] + a <- draws[, "a"] x_i <- unlist(data_i[, c("X1", "X2")]) - e <- (data_i$y - draws[,"a"] * x_i[1] - draws[,"b"] * x_i[2]) + e <- (data_i$y - draws[, "a"] * x_i[1] - draws[, "b"] * x_i[2]) - gr <- cbind(e * x_i[1] / sigma2, - e * x_i[2] / sigma2, - - 1 / sigma + e^2 / (sigma2 * sigma)) + gr <- cbind( + e * x_i[1] / sigma2, + e * x_i[2] / sigma2, + -1 / sigma + e^2 / (sigma2 * sigma) + ) colnames(gr) <- c("a", "b", "sigma") gr } .llhess <- function(data_i, draws) { - hess_array <- array(0, dim = c(ncol(draws), ncol(draws), nrow(draws)), dimnames = list(colnames(draws),colnames(draws),NULL)) - sigma <- draws[,"sigma"] + hess_array <- array( + 0, + dim = c(ncol(draws), ncol(draws), nrow(draws)), + dimnames = list(colnames(draws), colnames(draws), NULL) + ) + sigma <- draws[, "sigma"] sigma2 <- sigma^2 - sigma3 <- sigma2*sigma - b <- draws[,"b"] - a <- draws[,"a"] + sigma3 <- sigma2 * sigma + b <- draws[, "b"] + a <- draws[, "a"] x_i <- unlist(data_i[, c("X1", "X2")]) - e <- (data_i$y - draws[,"a"] * x_i[1] - draws[,"b"] * x_i[2]) - - hess_array[1,1,] <- - x_i[1]^2 / sigma2 - hess_array[1,2,] <- hess_array[2,1,] <- - x_i[1] * x_i[2] / sigma2 - hess_array[2,2,] <- - x_i[2]^2 / sigma2 - hess_array[3,1,] <- hess_array[1,3,] <- -2 * x_i[1] * e / sigma3 - hess_array[3,2,] <- hess_array[2,3,] <- -2 * x_i[2] * e / sigma3 - hess_array[3,3,] <- 1 / sigma2 - 3 * e^2 / (sigma2^2) + e <- (data_i$y - draws[, "a"] * x_i[1] - draws[, "b"] * x_i[2]) + + hess_array[1, 1, ] <- -x_i[1]^2 / sigma2 + hess_array[1, 2, ] <- hess_array[2, 1, ] <- -x_i[1] * x_i[2] / sigma2 + hess_array[2, 2, ] <- -x_i[2]^2 / sigma2 + hess_array[3, 1, ] <- hess_array[1, 3, ] <- -2 * x_i[1] * e / sigma3 + hess_array[3, 2, ] <- hess_array[2, 3, ] <- -2 * x_i[2] * e / sigma3 + hess_array[3, 3, ] <- 1 / sigma2 - 3 * e^2 / (sigma2^2) hess_array } @@ -555,59 +1357,135 @@ test_that("waic using delta 2nd order method", { fake_posterior <- cbind(fake_posterior, runif(nrow(fake_posterior))) #draws <- fake_posterior <- cbind(fake_posterior, runif(nrow(fake_posterior))) - expect_silent(approx_loo_waic <- loo:::elpd_loo_approximation(.llfun, data = fake_data, draws = fake_posterior, cores = 1, loo_approximation = "waic")) - expect_silent(approx_loo_waic_delta <- loo:::elpd_loo_approximation(.llfun, data = fake_data, draws = fake_posterior, cores = 1, loo_approximation = "waic_grad", .llgrad = .llgrad)) - expect_silent(approx_loo_waic_delta2 <- loo:::elpd_loo_approximation(.llfun, data = fake_data, draws = fake_posterior, cores = 1, loo_approximation = "waic_hess", .llgrad = .llgrad, .llhess = .llhess)) + expect_silent( + approx_loo_waic <- loo:::elpd_loo_approximation( + .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + loo_approximation = "waic" + ) + ) + expect_silent( + approx_loo_waic_delta <- loo:::elpd_loo_approximation( + .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + loo_approximation = "waic_grad", + .llgrad = .llgrad + ) + ) + expect_silent( + approx_loo_waic_delta2 <- loo:::elpd_loo_approximation( + .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + loo_approximation = "waic_hess", + .llgrad = .llgrad, + .llhess = .llhess + ) + ) # Test that the approaches should not deviate too much - expect_equal(approx_loo_waic,approx_loo_waic_delta2, tol = 0.01) - expect_equal(approx_loo_waic,approx_loo_waic_delta, tol = 0.01) - - expect_silent(test_loo_ss_waic <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic", observations = 50, llgrad = .llgrad)) - expect_error(test_loo_ss_delta2 <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic_hess", observations = 50, llgrad = .llgrad)) - expect_silent(test_loo_ss_delta2 <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic_hess", observations = 50, llgrad = .llgrad, llhess = .llhess)) - expect_silent(test_loo_ss_delta <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "waic_grad", observations = 50, llgrad = .llgrad)) - expect_silent(test_loo_ss_point <- loo_subsample(x = .llfun, data = fake_data, draws = fake_posterior, cores = 1, r_eff = rep(1, nrow(fake_data)), loo_approximation = "plpd", observations = 50, llgrad = .llgrad)) + expect_equal(approx_loo_waic, approx_loo_waic_delta2, tol = 0.01) + expect_equal(approx_loo_waic, approx_loo_waic_delta, tol = 0.01) + + expect_silent( + test_loo_ss_waic <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic", + observations = 50, + llgrad = .llgrad + ) + ) + expect_error( + test_loo_ss_delta2 <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic_hess", + observations = 50, + llgrad = .llgrad + ) + ) + expect_silent( + test_loo_ss_delta2 <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic_hess", + observations = 50, + llgrad = .llgrad, + llhess = .llhess + ) + ) + expect_silent( + test_loo_ss_delta <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "waic_grad", + observations = 50, + llgrad = .llgrad + ) + ) + expect_silent( + test_loo_ss_point <- loo_subsample( + x = .llfun, + data = fake_data, + draws = fake_posterior, + cores = 1, + r_eff = rep(1, nrow(fake_data)), + loo_approximation = "plpd", + observations = 50, + llgrad = .llgrad + ) + ) }) - - - - - context("loo_subsampling_estimation") test_that("whhest works as expected", { - - N <- 100 m <- 10 - z <- rep(1/N, m) + z <- rep(1 / N, m) y <- 1:10 - m_i <- rep(1,m) + m_i <- rep(1, m) expect_silent(whe <- loo:::whhest(z = z, m_i = m_i, y = y, N = N)) expect_equal(whe$y_hat_ppz, 550) - man_var <- (sum((whe$y_hat_ppz - y/z)^2)/(m-1))/m + man_var <- (sum((whe$y_hat_ppz - y / z)^2) / (m - 1)) / m expect_equal(whe$v_hat_y_ppz, man_var) - z <- 1:10/(sum(1:10)*10) + z <- 1:10 / (sum(1:10) * 10) expect_silent(whe <- loo:::whhest(z = z, m_i = m_i, y = y, N = N)) expect_equal(whe$y_hat_ppz, 550) expect_equal(whe$v_hat_y_ppz, 0) # School book example # https://newonlinecourses.science.psu.edu/stat506/node/15/ - z <- c(650/15650, 2840/15650, 3200/15650) + z <- c(650 / 15650, 2840 / 15650, 3200 / 15650) y <- c(420, 1785, 2198) - m_i <- c(1,1,1) + m_i <- c(1, 1, 1) N <- 10 expect_silent(whe <- loo:::whhest(z = z, m_i = m_i, y = y, N = N)) expect_equal(round(whe$y_hat_ppz, 2), 10232.75, tol = 0) expect_equal(whe$v_hat_y_ppz, 73125.74, tol = 0.01) # Double check that it is rounding error - man_var_round <- (sum((round(y/z,2) - 10232.75)^2)) * (1/2) * (1/3) + man_var_round <- (sum((round(y / z, 2) - 10232.75)^2)) * (1 / 2) * (1 / 3) expect_equal(man_var_round, 73125.74, tol = 0.001) - man_var_exact <- (sum((y/z - 10232.75)^2)) * (1/2) * (1/3) + man_var_exact <- (sum((y / z - 10232.75)^2)) * (1 / 2) * (1 / 3) expect_equal(whe$v_hat_y_ppz, man_var_exact, tol = 0.001) # Add test for variance estimation @@ -615,7 +1493,7 @@ test_that("whhest works as expected", { m <- 10 y <- rep(1:10, 1) true_var <- var(rep(y, 10)) * (99) - z <- rep(1/N, m) + z <- rep(1 / N, m) m_i <- rep(100000, m) expect_silent(whe <- loo:::whhest(z = z, m_i = m_i, y = y, N = N)) expect_equal(true_var, whe$hat_v_y_ppz, tol = 0.01) @@ -624,24 +1502,21 @@ test_that("whhest works as expected", { N <- 100 y <- rep(1:10, 2) m <- length(y) - z <- rep(1/N, m) - m_i <- rep(1,m) + z <- rep(1 / N, m) + m_i <- rep(1, m) expect_silent(whe1 <- loo:::whhest(z = z, m_i = m_i, y = y, N = N)) y <- rep(1:10) m <- length(y) - z <- rep(1/N, m) - m_i <- rep(2,m) + z <- rep(1 / N, m) + m_i <- rep(2, m) expect_silent(whe2 <- loo:::whhest(z = z, m_i = m_i, y = y, N = N)) expect_equal(whe1$y_hat_ppz, whe2$y_hat_ppz) expect_equal(whe1$v_hat_y_ppz, whe2$v_hat_y_ppz) expect_equal(whe1$hat_v_y_ppz, whe1$hat_v_y_ppz) - }) test_that("srs_diff_est works as expected", { - - set.seed(1234) N <- 1000 y_true <- 1:N @@ -649,7 +1524,7 @@ test_that("srs_diff_est works as expected", { y_approx <- rnorm(N, y_true, 0.1) m <- 100 sigma_hat <- y_hat <- se_y_hat <- numeric(10000) - for(i in 1:10000){ + for (i in 1:10000) { y_idx <- sample(1:N, size = m) y <- y_true[y_idx] res <- loo:::srs_diff_est(y_approx, y, y_idx) @@ -659,7 +1534,8 @@ test_that("srs_diff_est works as expected", { } expect_equal(mean(y_hat), sum(y_true), tol = 0.1) - in_ki <- y_hat + 2 * se_y_hat > sum(y_true) & y_hat - 2*se_y_hat < sum(y_true) + in_ki <- y_hat + 2 * se_y_hat > sum(y_true) & + y_hat - 2 * se_y_hat < sum(y_true) expect_equal(mean(in_ki), 0.95, tol = 0.01) # Should be unbiased @@ -672,22 +1548,45 @@ test_that("srs_diff_est works as expected", { expect_equal(res$y_hat, 500500, tol = 0.0001) expect_equal(res$v_y_hat, 0, tol = 0.0001) expect_equal(sqrt(res$hat_v_y), sigma_hat_true, tol = 0.1) - }) test_that("srs_est works as expected", { - - set.seed(1234) # Cochran 1976 example Table 2.2 - y <- c(rep(42,23),rep(41,4), 36, 32, 29, 27, 27, 23, 19, 16, 16, 15, 15, 14, 11, 10, 9, 7, 6, 6, 6, 5, 5, 4, 3) + y <- c( + rep(42, 23), + rep(41, 4), + 36, + 32, + 29, + 27, + 27, + 23, + 19, + 16, + 16, + 15, + 15, + 14, + 11, + 10, + 9, + 7, + 6, + 6, + 6, + 5, + 5, + 4, + 3 + ) expect_equal(sum(y), 1471) approx_loo <- rep(0L, 676) expect_equal(sum(y^2), 54497) res <- loo:::srs_est(y = y, approx_loo) expect_equal(res$y_hat, 19888, tol = 0.0001) - expect_equal(res$v_y_hat, 676^2*229*(1-0.074)/50, tol = 0.0001) + expect_equal(res$v_y_hat, 676^2 * 229 * (1 - 0.074) / 50, tol = 0.0001) expect_equal(res$hat_v_y, 676 * var(y), tol = 0.0001) # Simulation example @@ -698,7 +1597,7 @@ test_that("srs_est works as expected", { m <- 100 y_hat <- se_y_hat <- sigma_hat <- numeric(10000) - for(i in 1:10000){ + for (i in 1:10000) { y_idx <- sample(1:N, size = m) y <- y_true[y_idx] res <- loo:::srs_est(y = y, y_approx = y_true) @@ -708,7 +1607,8 @@ test_that("srs_est works as expected", { } expect_equal(mean(y_hat), sum(y_true), tol = 0.1) - in_ki <- y_hat + 2*se_y_hat > sum(y_true) & y_hat - 2*se_y_hat < sum(y_true) + in_ki <- y_hat + 2 * se_y_hat > sum(y_true) & + y_hat - 2 * se_y_hat < sum(y_true) expect_equal(mean(in_ki), 0.95, tol = 0.01) # Should be unbiased @@ -720,12 +1620,9 @@ test_that("srs_est works as expected", { res <- loo:::srs_est(y, y_true) expect_equal(res$y_hat, 500500, tol = 0.0001) expect_equal(res$v_y_hat, 0, tol = 0.0001) - }) - - context("loo_subsampling cases") test_that("Test loo_subsampling and loo_approx with radon data", { @@ -738,62 +1635,187 @@ test_that("Test loo_subsampling and loo_approx with radon data", { log_g_test <- log_q draws_test <- draws data_test <- data - rm(llfun, log_p,log_q, draws, data) + rm(llfun, log_p, log_q, draws, data) set.seed(134) - expect_silent(full_loo <- loo(llfun_test, draws = draws_test, data = data_test, r_eff = rep(1, nrow(data_test)))) + expect_silent( + full_loo <- loo( + llfun_test, + draws = draws_test, + data = data_test, + r_eff = rep(1, nrow(data_test)) + ) + ) expect_s3_class(full_loo, "psis_loo") set.seed(134) - expect_silent(loo_ss <- loo_subsample(x = llfun_test, draws = draws_test, data = data_test, observations = 200, loo_approximation = "plpd", r_eff = rep(1, nrow(data_test)))) + expect_silent( + loo_ss <- loo_subsample( + x = llfun_test, + draws = draws_test, + data = data_test, + observations = 200, + loo_approximation = "plpd", + r_eff = rep(1, nrow(data_test)) + ) + ) expect_s3_class(loo_ss, "psis_loo_ss") set.seed(134) - expect_silent(loo_ap_ss <- loo_subsample(x = llfun_test, draws = draws_test, data = data_test, log_p = log_p_test, log_g = log_g_test, observations = 200, loo_approximation = "plpd", r_eff = rep(1, nrow(data_test)))) + expect_silent( + loo_ap_ss <- loo_subsample( + x = llfun_test, + draws = draws_test, + data = data_test, + log_p = log_p_test, + log_g = log_g_test, + observations = 200, + loo_approximation = "plpd", + r_eff = rep(1, nrow(data_test)) + ) + ) expect_s3_class(loo_ap_ss, "psis_loo_ss") expect_s3_class(loo_ap_ss, "psis_loo_ap") - expect_silent(loo_ap_ss_full <- loo_subsample(x = llfun_test, log_p = log_p_test, log_g = log_g_test, draws = draws_test, data = data_test, observations = NULL, loo_approximation = "plpd", r_eff = rep(1, nrow(data_test)))) + expect_silent( + loo_ap_ss_full <- loo_subsample( + x = llfun_test, + log_p = log_p_test, + log_g = log_g_test, + draws = draws_test, + data = data_test, + observations = NULL, + loo_approximation = "plpd", + r_eff = rep(1, nrow(data_test)) + ) + ) expect_failure(expect_s3_class(loo_ap_ss_full, "psis_loo_ss")) expect_s3_class(loo_ap_ss_full, "psis_loo_ap") # Expect similar results z <- 2 - expect_lte(loo_ss$estimates["elpd_loo", "Estimate"] - z * loo_ss$estimates["elpd_loo", "subsampling SE"], full_loo$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ss$estimates["elpd_loo", "Estimate"] + z * loo_ss$estimates["elpd_loo", "subsampling SE"], full_loo$estimates["elpd_loo", "Estimate"]) - expect_lte(loo_ss$estimates["p_loo", "Estimate"] - z * loo_ss$estimates["p_loo", "subsampling SE"], full_loo$estimates["p_loo", "Estimate"]) - expect_gte(loo_ss$estimates["p_loo", "Estimate"] + z * loo_ss$estimates["p_loo", "subsampling SE"], full_loo$estimates["p_loo", "Estimate"]) - expect_lte(loo_ss$estimates["looic", "Estimate"] - z * loo_ss$estimates["looic", "subsampling SE"], full_loo$estimates["looic", "Estimate"]) - expect_gte(loo_ss$estimates["looic", "Estimate"] + z * loo_ss$estimates["looic", "subsampling SE"], full_loo$estimates["looic", "Estimate"]) - - expect_failure(expect_equal(full_loo$estimates["elpd_loo", "Estimate"], loo_ss$estimates["elpd_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(full_loo$estimates["p_loo", "Estimate"], loo_ss$estimates["p_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(full_loo$estimates["looic", "Estimate"], loo_ss$estimates["looic", "Estimate"], tol = 0.00000001)) + expect_lte( + loo_ss$estimates["elpd_loo", "Estimate"] - + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + full_loo$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["elpd_loo", "Estimate"] + + z * loo_ss$estimates["elpd_loo", "subsampling SE"], + full_loo$estimates["elpd_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["p_loo", "Estimate"] - + z * loo_ss$estimates["p_loo", "subsampling SE"], + full_loo$estimates["p_loo", "Estimate"] + ) + expect_gte( + loo_ss$estimates["p_loo", "Estimate"] + + z * loo_ss$estimates["p_loo", "subsampling SE"], + full_loo$estimates["p_loo", "Estimate"] + ) + expect_lte( + loo_ss$estimates["looic", "Estimate"] - + z * loo_ss$estimates["looic", "subsampling SE"], + full_loo$estimates["looic", "Estimate"] + ) + expect_gte( + loo_ss$estimates["looic", "Estimate"] + + z * loo_ss$estimates["looic", "subsampling SE"], + full_loo$estimates["looic", "Estimate"] + ) + + expect_failure(expect_equal( + full_loo$estimates["elpd_loo", "Estimate"], + loo_ss$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + full_loo$estimates["p_loo", "Estimate"], + loo_ss$estimates["p_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + full_loo$estimates["looic", "Estimate"], + loo_ss$estimates["looic", "Estimate"], + tol = 0.00000001 + )) z <- 2 - expect_lte(loo_ap_ss$estimates["elpd_loo", "Estimate"] - z * loo_ap_ss$estimates["elpd_loo", "subsampling SE"], loo_ap_ss_full$estimates["elpd_loo", "Estimate"]) - expect_gte(loo_ap_ss$estimates["elpd_loo", "Estimate"] + z * loo_ap_ss$estimates["elpd_loo", "subsampling SE"], loo_ap_ss_full$estimates["elpd_loo", "Estimate"]) - expect_lte(loo_ap_ss$estimates["p_loo", "Estimate"] - z * loo_ap_ss$estimates["p_loo", "subsampling SE"], loo_ap_ss_full$estimates["p_loo", "Estimate"]) - expect_gte(loo_ap_ss$estimates["p_loo", "Estimate"] + z * loo_ap_ss$estimates["p_loo", "subsampling SE"], loo_ap_ss_full$estimates["p_loo", "Estimate"]) - expect_lte(loo_ap_ss$estimates["looic", "Estimate"] - z * loo_ap_ss$estimates["looic", "subsampling SE"], loo_ap_ss_full$estimates["looic", "Estimate"]) - expect_gte(loo_ap_ss$estimates["looic", "Estimate"] + z * loo_ap_ss$estimates["looic", "subsampling SE"], loo_ap_ss_full$estimates["looic", "Estimate"]) - - expect_failure(expect_equal(loo_ap_ss_full$estimates["elpd_loo", "Estimate"], loo_ap_ss$estimates["elpd_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(loo_ap_ss_full$estimates["p_loo", "Estimate"], loo_ap_ss$estimates["p_loo", "Estimate"], tol = 0.00000001)) - expect_failure(expect_equal(loo_ap_ss_full$estimates["looic", "Estimate"], loo_ap_ss$estimates["looic", "Estimate"], tol = 0.00000001)) + expect_lte( + loo_ap_ss$estimates["elpd_loo", "Estimate"] - + z * loo_ap_ss$estimates["elpd_loo", "subsampling SE"], + loo_ap_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_gte( + loo_ap_ss$estimates["elpd_loo", "Estimate"] + + z * loo_ap_ss$estimates["elpd_loo", "subsampling SE"], + loo_ap_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_lte( + loo_ap_ss$estimates["p_loo", "Estimate"] - + z * loo_ap_ss$estimates["p_loo", "subsampling SE"], + loo_ap_ss_full$estimates["p_loo", "Estimate"] + ) + expect_gte( + loo_ap_ss$estimates["p_loo", "Estimate"] + + z * loo_ap_ss$estimates["p_loo", "subsampling SE"], + loo_ap_ss_full$estimates["p_loo", "Estimate"] + ) + expect_lte( + loo_ap_ss$estimates["looic", "Estimate"] - + z * loo_ap_ss$estimates["looic", "subsampling SE"], + loo_ap_ss_full$estimates["looic", "Estimate"] + ) + expect_gte( + loo_ap_ss$estimates["looic", "Estimate"] + + z * loo_ap_ss$estimates["looic", "subsampling SE"], + loo_ap_ss_full$estimates["looic", "Estimate"] + ) + + expect_failure(expect_equal( + loo_ap_ss_full$estimates["elpd_loo", "Estimate"], + loo_ap_ss$estimates["elpd_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + loo_ap_ss_full$estimates["p_loo", "Estimate"], + loo_ap_ss$estimates["p_loo", "Estimate"], + tol = 0.00000001 + )) + expect_failure(expect_equal( + loo_ap_ss_full$estimates["looic", "Estimate"], + loo_ap_ss$estimates["looic", "Estimate"], + tol = 0.00000001 + )) # Correct printout - expect_failure(expect_output(print(full_loo), "Posterior approximation correction used\\.")) - expect_failure(expect_output(print(full_loo), "subsampled log-likelihood\nvalues")) - - expect_failure(expect_output(print(loo_ss), "Posterior approximation correction used\\.")) + expect_failure(expect_output( + print(full_loo), + "Posterior approximation correction used\\." + )) + expect_failure(expect_output( + print(full_loo), + "subsampled log-likelihood\nvalues" + )) + + expect_failure(expect_output( + print(loo_ss), + "Posterior approximation correction used\\." + )) expect_output(print(loo_ss), "subsampled log-likelihood\nvalues") expect_output(print(loo_ap_ss), "Posterior approximation correction used\\.") expect_output(print(loo_ap_ss), "subsampled log-likelihood\nvalues") - expect_output(print(loo_ap_ss_full), "Posterior approximation correction used\\.") - expect_failure(expect_output(print(loo_ap_ss_full), "subsampled log-likelihood\nvalues")) + expect_output( + print(loo_ap_ss_full), + "Posterior approximation correction used\\." + ) + expect_failure(expect_output( + print(loo_ap_ss_full), + "subsampled log-likelihood\nvalues" + )) # Test conversion of objects expect_silent(loo_ap_full <- loo:::as.psis_loo.psis_loo(loo_ap_ss_full)) @@ -804,43 +1826,60 @@ test_that("Test loo_subsampling and loo_approx with radon data", { expect_silent(loo_ap_full2 <- loo:::as.psis_loo.psis_loo_ss(loo_ap_full_ss)) expect_s3_class(loo_ap_full2, "psis_loo_ap") expect_failure(expect_s3_class(loo_ap_full2, "psis_loo_ss")) - expect_equal(loo_ap_full2,loo_ap_full) + expect_equal(loo_ap_full2, loo_ap_full) # Test update set.seed(4712) - expect_silent(loo_ss2 <- update(loo_ss, draws = draws_test, data = data_test, observations = 1000, r_eff = rep(1, nrow(data_test)))) + expect_silent( + loo_ss2 <- update( + loo_ss, + draws = draws_test, + data = data_test, + observations = 1000, + r_eff = rep(1, nrow(data_test)) + ) + ) expect_gt(dim(loo_ss2)[2], dim(loo_ss)[2]) expect_gt(dim(loo_ss2$pointwise)[1], dim(loo_ss$pointwise)[1]) expect_equal(nobs(loo_ss), 200) expect_equal(nobs(loo_ss2), 1000) - for(i in 1:nrow(loo_ss2$estimates)) { - expect_lt(loo_ss2$estimates[i, "subsampling SE"], - loo_ss$estimates[i, "subsampling SE"]) + for (i in 1:nrow(loo_ss2$estimates)) { + expect_lt( + loo_ss2$estimates[i, "subsampling SE"], + loo_ss$estimates[i, "subsampling SE"] + ) } set.seed(4712) - expect_silent(loo_ap_ss2 <- update(object = loo_ap_ss, draws = draws_test, data = data_test, observations = 2000)) + expect_silent( + loo_ap_ss2 <- update( + object = loo_ap_ss, + draws = draws_test, + data = data_test, + observations = 2000 + ) + ) expect_gt(dim(loo_ap_ss2)[2], dim(loo_ap_ss)[2]) expect_gt(dim(loo_ap_ss2$pointwise)[1], dim(loo_ap_ss$pointwise)[1]) expect_equal(nobs(loo_ap_ss), 200) expect_equal(nobs(loo_ap_ss2), 2000) - for(i in 1:nrow(loo_ap_ss2$estimates)) { - expect_lt(loo_ap_ss2$estimates[i, "subsampling SE"], - loo_ap_ss$estimates[i, "subsampling SE"]) + for (i in 1:nrow(loo_ap_ss2$estimates)) { + expect_lt( + loo_ap_ss2$estimates[i, "subsampling SE"], + loo_ap_ss$estimates[i, "subsampling SE"] + ) } expect_equal(round(full_loo$estimates), round(loo_ap_ss_full$estimates)) expect_failure(expect_equal(full_loo$estimates, loo_ap_ss_full$estimates)) expect_equal(dim(full_loo), dim(loo_ap_ss_full)) expect_s3_class(loo_ap_ss_full, "psis_loo_ap") - }) test_that("Test the vignette", { skip_on_cran() - # NOTE # If any of these test fails, the vignette probably needs to be updated @@ -865,9 +1904,12 @@ test_that("Test the vignette", { # logistic <- function(x) {1 / (1 + exp(-x))} # logit <- function(x) {log(x) - log(1-x)} llfun_logistic <- function(data_i, draws) { - x_i <- as.matrix(data_i[, which(grepl(colnames(data_i), pattern = "X")), drop=FALSE]) + x_i <- as.matrix(data_i[, + which(grepl(colnames(data_i), pattern = "X")), + drop = FALSE + ]) y_pred <- draws %*% t(x_i) - dbinom(x = data_i$y, size = 1, prob = 1 / (1 + exp(-y_pred)), log = TRUE) + dbinom(x = data_i$y, size = 1, prob = 1 / (1 + exp(-y_pred)), log = TRUE) } # Prepare data @@ -900,98 +1942,233 @@ test_that("Test the vignette", { fit_2 <- stan(fit = fit_1, data = standata, seed = 4711) parameter_draws_2 <- extract(fit_2)$beta - save(llfun_logistic, - stan_df, stan_df2, - parameter_draws, parameter_draws_laplace, parameter_draws_2, - log_p, log_g, - file = test_path("data-for-tests/loo_subsample_vignette.rda"), compression_level = 9) - + save( + llfun_logistic, + stan_df, + stan_df2, + parameter_draws, + parameter_draws_laplace, + parameter_draws_2, + log_p, + log_g, + file = test_path("data-for-tests/loo_subsample_vignette.rda"), + compression_level = 9 + ) } else { load(test_path("data-for-tests/loo_subsample_vignette.rda")) } set.seed(4711) - expect_no_warning(looss_1 <- loo_subsample(llfun_logistic, draws = parameter_draws, data = stan_df, observations = 100)) - expect_output(print(looss_1), "Computed from 4000 by 100 subsampled log-likelihood") + expect_no_warning( + looss_1 <- loo_subsample( + llfun_logistic, + draws = parameter_draws, + data = stan_df, + observations = 100 + ) + ) + expect_output( + print(looss_1), + "Computed from 4000 by 100 subsampled log-likelihood" + ) expect_output(print(looss_1), "values from 3020 total observations.") - expect_output(print(looss_1), "MCSE and ESS estimates assume independent draws") + expect_output( + print(looss_1), + "MCSE and ESS estimates assume independent draws" + ) expect_output(print(looss_1), "elpd_loo -1968.5 15.6 0.3") expect_output(print(looss_1), "p_loo 3.1 0.1 0.4") expect_s3_class(looss_1, c("psis_loo_ss", "psis_loo", "loo")) set.seed(4711) - expect_no_warning(looss_1b <- update(looss_1, draws = parameter_draws, data = stan_df, observations = 200)) - expect_output(print(looss_1b), "Computed from 4000 by 200 subsampled log-likelihood") + expect_no_warning( + looss_1b <- update( + looss_1, + draws = parameter_draws, + data = stan_df, + observations = 200 + ) + ) + expect_output( + print(looss_1b), + "Computed from 4000 by 200 subsampled log-likelihood" + ) expect_output(print(looss_1b), "values from 3020 total observations.") - expect_output(print(looss_1b), "MCSE and ESS estimates assume independent draws") + expect_output( + print(looss_1b), + "MCSE and ESS estimates assume independent draws" + ) expect_output(print(looss_1b), "elpd_loo -1968.3 15.6 0.2") expect_output(print(looss_1b), "p_loo 3.2 0.1 0.4") expect_s3_class(looss_1b, c("psis_loo_ss", "psis_loo", "loo")) set.seed(4711) - expect_no_warning(looss_2 <- loo_subsample(x = llfun_logistic, draws = parameter_draws, data = stan_df, observations = 100, estimator = "hh_pps", loo_approximation = "lpd", loo_approximation_draws = 100)) - expect_output(print(looss_2), "Computed from 4000 by 100 subsampled log-likelihood") + expect_no_warning( + looss_2 <- loo_subsample( + x = llfun_logistic, + draws = parameter_draws, + data = stan_df, + observations = 100, + estimator = "hh_pps", + loo_approximation = "lpd", + loo_approximation_draws = 100 + ) + ) + expect_output( + print(looss_2), + "Computed from 4000 by 100 subsampled log-likelihood" + ) expect_output(print(looss_2), "values from 3020 total observations.") - expect_output(print(looss_2), "MCSE and ESS estimates assume independent draws") + expect_output( + print(looss_2), + "MCSE and ESS estimates assume independent draws" + ) # Currently failing # expect_output(print(looss_2), "elpd_loo -1968.9 15.4 0.5") # expect_output(print(looss_2), "p_loo 3.5 0.2 0.5") expect_s3_class(looss_2, c("psis_loo_ss", "psis_loo", "loo")) set.seed(4711) - expect_no_warning(aploo_1 <- loo_approximate_posterior(llfun_logistic, draws = parameter_draws_laplace, data = stan_df, log_p = log_p, log_g = log_g)) - expect_output(print(aploo_1), "Computed from 2000 by 3020 log-likelihood matrix") - expect_output(print(aploo_1), "MCSE and ESS estimates assume independent draws") + expect_no_warning( + aploo_1 <- loo_approximate_posterior( + llfun_logistic, + draws = parameter_draws_laplace, + data = stan_df, + log_p = log_p, + log_g = log_g + ) + ) + expect_output( + print(aploo_1), + "Computed from 2000 by 3020 log-likelihood matrix" + ) + expect_output( + print(aploo_1), + "MCSE and ESS estimates assume independent draws" + ) expect_output(print(aploo_1), "elpd_loo -1968.4 15.6") expect_output(print(aploo_1), "p_loo 3.2 0.2") expect_output(print(aploo_1), "Posterior approximation correction used.") expect_output(print(aploo_1), "All Pareto k estimates are good") - expect_equal(length(pareto_k_ids(aploo_1,threshold=0.5)), 31) + expect_equal(length(pareto_k_ids(aploo_1, threshold = 0.5)), 31) expect_s3_class(aploo_1, c("psis_loo_ap", "psis_loo", "loo")) set.seed(4711) - expect_no_warning(looapss_1 <- loo_subsample(llfun_logistic, draws = parameter_draws_laplace, data = stan_df, log_p = log_p, log_g = log_g, observations = 100)) - expect_output(print(looapss_1), "Computed from 2000 by 100 subsampled log-likelihood") - expect_output(print(looapss_1), "MCSE and ESS estimates assume independent draws") + expect_no_warning( + looapss_1 <- loo_subsample( + llfun_logistic, + draws = parameter_draws_laplace, + data = stan_df, + log_p = log_p, + log_g = log_g, + observations = 100 + ) + ) + expect_output( + print(looapss_1), + "Computed from 2000 by 100 subsampled log-likelihood" + ) + expect_output( + print(looapss_1), + "MCSE and ESS estimates assume independent draws" + ) expect_output(print(looapss_1), "values from 3020 total observations.") expect_output(print(looapss_1), "elpd_loo -1968.2 15.6 0.4") expect_output(print(looapss_1), "p_loo 2.9 0.1 0.5") expect_output(print(looapss_1), "All Pareto k estimates are good") - expect_equal(length(pareto_k_ids(looapss_1,threshold=0.5)), 3) + expect_equal(length(pareto_k_ids(looapss_1, threshold = 0.5)), 3) # Loo compare set.seed(4711) - expect_no_warning(looss_1 <- loo_subsample(llfun_logistic, draws = parameter_draws, data = stan_df, observations = 100)) + expect_no_warning( + looss_1 <- loo_subsample( + llfun_logistic, + draws = parameter_draws, + data = stan_df, + observations = 100 + ) + ) set.seed(4712) - expect_no_warning(looss_2 <- loo_subsample(x = llfun_logistic, draws = parameter_draws_2, data = stan_df2, observations = 100)) - expect_output(print(looss_2), "Computed from 4000 by 100 subsampled log-likelihood") - expect_output(print(looss_2), "MCSE and ESS estimates assume independent draws") + expect_no_warning( + looss_2 <- loo_subsample( + x = llfun_logistic, + draws = parameter_draws_2, + data = stan_df2, + observations = 100 + ) + ) + expect_output( + print(looss_2), + "Computed from 4000 by 100 subsampled log-likelihood" + ) + expect_output( + print(looss_2), + "MCSE and ESS estimates assume independent draws" + ) expect_output(print(looss_2), "values from 3020 total observations.") expect_output(print(looss_2), "elpd_loo -1952.0 16.2 0.2") expect_output(print(looss_2), "p_loo 2.6 0.1 0.3") - expect_warning(comp <- loo_compare(looss_1, looss_2), "Different subsamples in 'model2' and 'model1'. Naive diff SE is used.") + expect_warning( + comp <- loo_compare(looss_1, looss_2), + "Different subsamples in 'model2' and 'model1'. Naive diff SE is used." + ) expect_output(print(comp), "model1 16.5 22.5 0.4") set.seed(4712) - expect_no_warning(looss_2_m <- loo_subsample(x = llfun_logistic, draws = parameter_draws_2, data = stan_df2, observations = looss_1)) - expect_message(looss_2_m <- suppressWarnings(loo_subsample(x = llfun_logistic, draws = parameter_draws_2, data = stan_df2, observations = obs_idx(looss_1))), - "Simple random sampling with replacement assumed.") + expect_no_warning( + looss_2_m <- loo_subsample( + x = llfun_logistic, + draws = parameter_draws_2, + data = stan_df2, + observations = looss_1 + ) + ) + expect_message( + looss_2_m <- suppressWarnings(loo_subsample( + x = llfun_logistic, + draws = parameter_draws_2, + data = stan_df2, + observations = obs_idx(looss_1) + )), + "Simple random sampling with replacement assumed." + ) expect_silent(comp <- loo_compare(looss_1, looss_2_m)) expect_output(print(comp), "model1 16.1 4.4 0.1") set.seed(4712) - expect_no_warning(looss_1 <- update(looss_1, draws = parameter_draws, data = stan_df, observations = 200)) - expect_no_warning(looss_2_m <- update(looss_2_m, draws = parameter_draws_2, data = stan_df2, observations = looss_1)) + expect_no_warning( + looss_1 <- update( + looss_1, + draws = parameter_draws, + data = stan_df, + observations = 200 + ) + ) + expect_no_warning( + looss_2_m <- update( + looss_2_m, + draws = parameter_draws_2, + data = stan_df2, + observations = looss_1 + ) + ) expect_silent(comp2 <- loo_compare(looss_1, looss_2_m)) expect_output(print(comp2), "model1 16.3 4.4 0.1") - expect_no_warning(looss_2_full <- loo(x = llfun_logistic, draws = parameter_draws_2, data = stan_df2)) - expect_message(comp3 <- loo_compare(x = list(looss_1, looss_2_full)), - "Estimated elpd_diff using observations included in loo calculations for all models.") + expect_no_warning( + looss_2_full <- loo( + x = llfun_logistic, + draws = parameter_draws_2, + data = stan_df2 + ) + ) + expect_message( + comp3 <- loo_compare(x = list(looss_1, looss_2_full)), + "Estimated elpd_diff using observations included in loo calculations for all models." + ) expect_output(print(comp3), "model1 16.5 4.4 0.3") - }) @@ -1006,69 +2183,169 @@ test_that("loo_compare_subsample", { x2 <- rnorm(N) x3 <- rnorm(N) sigma <- 2 - y <- rnorm(N, 1 + 2*x1 - 2*x2 - 1*x3, sd = sigma) + y <- rnorm(N, 1 + 2 * x1 - 2 * x2 - 1 * x3, sd = sigma) X <- cbind("x0" = rep(1, N), x1, x2, x3) # Generate samples from posterior - samples_blin <- function(X, y, sigma, draws = 1000){ - XtX <- t(X)%*%X + samples_blin <- function(X, y, sigma, draws = 1000) { + XtX <- t(X) %*% X b_hat <- solve(XtX) %*% (t(X) %*% y) Lambda_n = XtX + diag(ncol(X)) - mu_n <- solve(Lambda_n) %*% (XtX %*% b_hat + diag(ncol(X)) %*% rep(0,ncol(X))) + mu_n <- solve(Lambda_n) %*% + (XtX %*% b_hat + diag(ncol(X)) %*% rep(0, ncol(X))) L <- t(chol(sigma^2 * solve(Lambda_n))) - draws_mat <- matrix(0, ncol=ncol(X), nrow = draws) - for(i in 1:draws){ + draws_mat <- matrix(0, ncol = ncol(X), nrow = draws) + for (i in 1:draws) { z <- rnorm(length(mu_n)) - draws_mat[i,] <- L %*% z + mu_n + draws_mat[i, ] <- L %*% z + mu_n } draws_mat } - fake_posterior1 <- samples_blin(X[,1:2], y, sigma, draws = 1000) - fake_posterior2 <- samples_blin(X[,1:3], y, sigma, draws = 1000) + fake_posterior1 <- samples_blin(X[, 1:2], y, sigma, draws = 1000) + fake_posterior2 <- samples_blin(X[, 1:3], y, sigma, draws = 1000) fake_posterior3 <- samples_blin(X, y, sigma, draws = 1000) - fake_data1 <- data.frame(y, X[,1:2]) - fake_data2 <- data.frame(y, X[,1:3]) + fake_data1 <- data.frame(y, X[, 1:2]) + fake_data2 <- data.frame(y, X[, 1:3]) fake_data3 <- data.frame(y, X) llfun_test <- function(data_i, draws) { - dnorm(x = data_i$y, mean = draws %*% t(data_i[,-1, drop=FALSE]), sd = sigma, log = TRUE) + dnorm( + x = data_i$y, + mean = draws %*% t(data_i[, -1, drop = FALSE]), + sd = sigma, + log = TRUE + ) } - expect_silent(l1 <- loo(llfun_test, data = fake_data1, draws = fake_posterior1, r_eff = rep(1, N))) - expect_silent(l2 <- loo(llfun_test, data = fake_data2, draws = fake_posterior2, r_eff = rep(1, N))) - expect_silent(l3 <- loo(llfun_test, data = fake_data3, draws = fake_posterior3, r_eff = rep(1, N))) - - expect_silent(lss1 <- loo_subsample(llfun_test, data = fake_data1, draws = fake_posterior1, observations = 100, r_eff = rep(1, N))) - expect_silent(lss2 <- loo_subsample(llfun_test, data = fake_data2, draws = fake_posterior2, observations = 100, r_eff = rep(1, N))) - expect_silent(lss3 <- loo_subsample(llfun_test, data = fake_data3, draws = fake_posterior3, observations = 100, r_eff = rep(1, N))) - expect_silent(lss2o1 <- loo_subsample(llfun_test, data = fake_data2, draws = fake_posterior2, observations = lss1, r_eff = rep(1, N))) - expect_silent(lss3o1 <- loo_subsample(llfun_test, data = fake_data3, draws = fake_posterior3, observations = lss1, r_eff = rep(1, N))) - expect_silent(lss2hh <- loo_subsample(llfun_test, data = fake_data2, draws = fake_posterior2, observations = 100, estimator = "hh_pps", r_eff = rep(1, N))) - - expect_warning(lcss <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3))) - expect_warning(lcss2 <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3o1))) - expect_silent(lcsso <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2o1, lss3o1))) - expect_warning(lcssohh <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2hh, lss3o1))) - expect_message(lcssf1 <- loo:::loo_compare.psis_loo_ss_list(x = list(loo:::as.psis_loo_ss.psis_loo(l1), lss2o1, lss3o1))) - expect_message(lcssf2 <- loo:::loo_compare.psis_loo_ss_list(x = list(loo:::as.psis_loo_ss.psis_loo(l1), lss2o1, loo:::as.psis_loo_ss.psis_loo(l3)))) - - expect_equal(lcss[,1], lcsso[,1], tolerance = 1) - expect_equal(lcss2[,1], lcsso[,1], tolerance = 1) - expect_equal(lcssohh[,1], lcsso[,1], tolerance = 1) - expect_equal(lcssf1[,1], lcsso[,1], tolerance = 1) - expect_equal(lcssf2[,1], lcsso[,1], tolerance = 1) - - expect_gt(lcss[,2][2], lcsso[,2][2]) - expect_gt(lcss[,2][3], lcsso[,2][3]) - expect_gt(lcss2[,2][2], lcsso[,2][2]) - expect_equal(lcss2[,2][3], lcsso[,2][3]) - expect_gt(lcssohh[,2][2], lcsso[,2][2]) - expect_equal(lcssohh[,2][3], lcsso[,2][3]) - - expect_silent(lcss2m <- loo:::loo_compare.psis_loo_ss_list(x = list(lss2o1, lss3o1))) - expect_equal(unname(lcss2m[,]), unname(lcsso[1:2,])) + expect_silent( + l1 <- loo( + llfun_test, + data = fake_data1, + draws = fake_posterior1, + r_eff = rep(1, N) + ) + ) + expect_silent( + l2 <- loo( + llfun_test, + data = fake_data2, + draws = fake_posterior2, + r_eff = rep(1, N) + ) + ) + expect_silent( + l3 <- loo( + llfun_test, + data = fake_data3, + draws = fake_posterior3, + r_eff = rep(1, N) + ) + ) + + expect_silent( + lss1 <- loo_subsample( + llfun_test, + data = fake_data1, + draws = fake_posterior1, + observations = 100, + r_eff = rep(1, N) + ) + ) + expect_silent( + lss2 <- loo_subsample( + llfun_test, + data = fake_data2, + draws = fake_posterior2, + observations = 100, + r_eff = rep(1, N) + ) + ) + expect_silent( + lss3 <- loo_subsample( + llfun_test, + data = fake_data3, + draws = fake_posterior3, + observations = 100, + r_eff = rep(1, N) + ) + ) + expect_silent( + lss2o1 <- loo_subsample( + llfun_test, + data = fake_data2, + draws = fake_posterior2, + observations = lss1, + r_eff = rep(1, N) + ) + ) + expect_silent( + lss3o1 <- loo_subsample( + llfun_test, + data = fake_data3, + draws = fake_posterior3, + observations = lss1, + r_eff = rep(1, N) + ) + ) + expect_silent( + lss2hh <- loo_subsample( + llfun_test, + data = fake_data2, + draws = fake_posterior2, + observations = 100, + estimator = "hh_pps", + r_eff = rep(1, N) + ) + ) + + expect_warning( + lcss <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3)) + ) + expect_warning( + lcss2 <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3o1)) + ) + expect_silent( + lcsso <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2o1, lss3o1)) + ) + expect_warning( + lcssohh <- loo:::loo_compare.psis_loo_ss_list( + x = list(lss1, lss2hh, lss3o1) + ) + ) + expect_message( + lcssf1 <- loo:::loo_compare.psis_loo_ss_list( + x = list(loo:::as.psis_loo_ss.psis_loo(l1), lss2o1, lss3o1) + ) + ) + expect_message( + lcssf2 <- loo:::loo_compare.psis_loo_ss_list( + x = list( + loo:::as.psis_loo_ss.psis_loo(l1), + lss2o1, + loo:::as.psis_loo_ss.psis_loo(l3) + ) + ) + ) + + expect_equal(lcss[, 1], lcsso[, 1], tolerance = 1) + expect_equal(lcss2[, 1], lcsso[, 1], tolerance = 1) + expect_equal(lcssohh[, 1], lcsso[, 1], tolerance = 1) + expect_equal(lcssf1[, 1], lcsso[, 1], tolerance = 1) + expect_equal(lcssf2[, 1], lcsso[, 1], tolerance = 1) + + expect_gt(lcss[, 2][2], lcsso[, 2][2]) + expect_gt(lcss[, 2][3], lcsso[, 2][3]) + expect_gt(lcss2[, 2][2], lcsso[, 2][2]) + expect_equal(lcss2[, 2][3], lcsso[, 2][3]) + expect_gt(lcssohh[, 2][2], lcsso[, 2][2]) + expect_equal(lcssohh[, 2][3], lcsso[, 2][3]) + + expect_silent( + lcss2m <- loo:::loo_compare.psis_loo_ss_list(x = list(lss2o1, lss3o1)) + ) + expect_equal(unname(lcss2m[,]), unname(lcsso[1:2, ])) expect_warning(lcssapi <- loo_compare(lss1, lss2, lss3)) expect_equal(lcssapi, lcss) @@ -1076,7 +2353,6 @@ test_that("loo_compare_subsample", { expect_equal(lcssohhapi, lcssohh) expect_silent(lcss2mapi <- loo_compare(lss2o1, lss3o1)) expect_equal(lcss2mapi, lcss2m) - }) context("subsample with tis, sis") @@ -1085,91 +2361,175 @@ test_that("Test 'tis' and 'sis'", { skip_on_cran() set.seed(123) - N <- 1000; K <- 10; S <- 1000; a0 <- 3; b0 <- 2 + N <- 1000 + K <- 10 + S <- 1000 + a0 <- 3 + b0 <- 2 p <- 0.7 y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) fake_posterior <- draws <- as.matrix(rbeta(S, a, b)) - fake_data <- data.frame(y,K) + fake_data <- data.frame(y, K) rm(N, K, S, a0, b0, p, y, a, b) llfun_test <- function(data_i, draws) { dbinom(data_i$y, size = data_i$K, prob = draws, log = TRUE) } - expect_silent(loo_ss_full <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 1000, - loo_approximation = "plpd", - r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_plpd <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 100, - loo_approximation = "plpd", - r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_tis_S1000 <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 100, - loo_approximation = "tis", - r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_tis_S100 <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 100, - loo_approximation = "tis", - loo_approximation_draws = 100, - r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_tis_S10 <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 100, - loo_approximation = "tis", - loo_approximation_draws = 10, - r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_sis_S1000 <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 100, - loo_approximation = "sis", - r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_sis_S100 <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 100, - loo_approximation = "sis", - loo_approximation_draws = 100, - r_eff = rep(1, nrow(fake_data)))) - expect_silent(loo_ss_sis_S10 <- - loo_subsample(x = llfun_test, - draws = fake_posterior, - data = fake_data, - observations = 100, - loo_approximation = "sis", - loo_approximation_draws = 10, - r_eff = rep(1, nrow(fake_data)))) - + expect_silent( + loo_ss_full <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 1000, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_plpd <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "plpd", + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_tis_S1000 <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "tis", + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_tis_S100 <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "tis", + loo_approximation_draws = 100, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_tis_S10 <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "tis", + loo_approximation_draws = 10, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_sis_S1000 <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "sis", + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_sis_S100 <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "sis", + loo_approximation_draws = 100, + r_eff = rep(1, nrow(fake_data)) + ) + ) + expect_silent( + loo_ss_sis_S10 <- + loo_subsample( + x = llfun_test, + draws = fake_posterior, + data = fake_data, + observations = 100, + loo_approximation = "sis", + loo_approximation_draws = 10, + r_eff = rep(1, nrow(fake_data)) + ) + ) SEs <- 4 - expect_gt(loo_ss_tis_S1000$estimates["elpd_loo", "Estimate"] + SEs*loo_ss_tis_S1000$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_lt(loo_ss_tis_S1000$estimates["elpd_loo", "Estimate"] - SEs*loo_ss_tis_S1000$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_gt(loo_ss_tis_S100$estimates["elpd_loo", "Estimate"] + SEs*loo_ss_tis_S100$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_lt(loo_ss_tis_S100$estimates["elpd_loo", "Estimate"] - SEs*loo_ss_tis_S100$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_gt(loo_ss_tis_S10$estimates["elpd_loo", "Estimate"] + SEs*loo_ss_tis_S10$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_lt(loo_ss_tis_S10$estimates["elpd_loo", "Estimate"] - SEs*loo_ss_tis_S10$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - - expect_gt(loo_ss_sis_S1000$estimates["elpd_loo", "Estimate"] + SEs*loo_ss_sis_S1000$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_lt(loo_ss_sis_S1000$estimates["elpd_loo", "Estimate"] - SEs*loo_ss_sis_S1000$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_gt(loo_ss_sis_S100$estimates["elpd_loo", "Estimate"] + SEs*loo_ss_sis_S100$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_lt(loo_ss_sis_S100$estimates["elpd_loo", "Estimate"] - SEs*loo_ss_sis_S100$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_gt(loo_ss_sis_S10$estimates["elpd_loo", "Estimate"] + SEs*loo_ss_sis_S10$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) - expect_lt(loo_ss_sis_S10$estimates["elpd_loo", "Estimate"] - SEs*loo_ss_sis_S10$estimates["elpd_loo", "subsampling SE"], loo_ss_full$estimates["elpd_loo", "Estimate"]) + expect_gt( + loo_ss_tis_S1000$estimates["elpd_loo", "Estimate"] + + SEs * loo_ss_tis_S1000$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_lt( + loo_ss_tis_S1000$estimates["elpd_loo", "Estimate"] - + SEs * loo_ss_tis_S1000$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_gt( + loo_ss_tis_S100$estimates["elpd_loo", "Estimate"] + + SEs * loo_ss_tis_S100$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_lt( + loo_ss_tis_S100$estimates["elpd_loo", "Estimate"] - + SEs * loo_ss_tis_S100$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_gt( + loo_ss_tis_S10$estimates["elpd_loo", "Estimate"] + + SEs * loo_ss_tis_S10$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_lt( + loo_ss_tis_S10$estimates["elpd_loo", "Estimate"] - + SEs * loo_ss_tis_S10$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + + expect_gt( + loo_ss_sis_S1000$estimates["elpd_loo", "Estimate"] + + SEs * loo_ss_sis_S1000$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_lt( + loo_ss_sis_S1000$estimates["elpd_loo", "Estimate"] - + SEs * loo_ss_sis_S1000$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_gt( + loo_ss_sis_S100$estimates["elpd_loo", "Estimate"] + + SEs * loo_ss_sis_S100$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_lt( + loo_ss_sis_S100$estimates["elpd_loo", "Estimate"] - + SEs * loo_ss_sis_S100$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_gt( + loo_ss_sis_S10$estimates["elpd_loo", "Estimate"] + + SEs * loo_ss_sis_S10$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) + expect_lt( + loo_ss_sis_S10$estimates["elpd_loo", "Estimate"] - + SEs * loo_ss_sis_S10$estimates["elpd_loo", "subsampling SE"], + loo_ss_full$estimates["elpd_loo", "Estimate"] + ) }) diff --git a/tests/testthat/test_model_weighting.R b/tests/testthat/test_model_weighting.R index fb7c0e7c..dd93820c 100644 --- a/tests/testthat/test_model_weighting.R +++ b/tests/testthat/test_model_weighting.R @@ -4,19 +4,19 @@ context("loo_model_weights") # generate fake data set.seed(123) -y<-rnorm(50,0,1) -sd_sim1<- abs(rnorm(500,1.5, 0.1)) -sd_sim2<- abs(rnorm(500,1.2, 0.1)) -sd_sim3<- abs(rnorm(500,1, 0.05)) +y <- rnorm(50, 0, 1) +sd_sim1 <- abs(rnorm(500, 1.5, 0.1)) +sd_sim2 <- abs(rnorm(500, 1.2, 0.1)) +sd_sim3 <- abs(rnorm(500, 1, 0.05)) log_lik1 <- log_lik2 <- log_lik3 <- matrix(NA, 500, 50) -for(s in 1:500) { - log_lik1[s,] <- dnorm(y,-1,sd_sim1[s], log=T) - log_lik2[s,] <- dnorm(y,0.7,sd_sim2[s], log=T) - log_lik3[s,] <- dnorm(y,1,sd_sim3[s], log=T) +for (s in 1:500) { + log_lik1[s, ] <- dnorm(y, -1, sd_sim1[s], log = T) + log_lik2[s, ] <- dnorm(y, 0.7, sd_sim2[s], log = T) + log_lik3[s, ] <- dnorm(y, 1, sd_sim3[s], log = T) } -ll_list <- list(log_lik1, log_lik2,log_lik3) -r_eff_list <- list(rep(0.9,50), rep(0.9,50), rep(0.9,50)) +ll_list <- list(log_lik1, log_lik2, log_lik3) +r_eff_list <- list(rep(0.9, 50), rep(0.9, 50), rep(0.9, 50)) loo_list <- lapply(1:length(ll_list), function(j) { loo(ll_list[[j]], r_eff = r_eff_list[[j]]) @@ -25,28 +25,46 @@ loo_list <- lapply(1:length(ll_list), function(j) { tol <- 0.01 # absoulte tolerance of weights test_that("loo_model_weights throws correct errors and warnings", { - expect_error(loo_model_weights(log_lik1), "list of matrices or a list of 'psis_loo' objects") + expect_error( + loo_model_weights(log_lik1), + "list of matrices or a list of 'psis_loo' objects" + ) expect_error(loo_model_weights(list(log_lik1)), "At least two models") expect_error(loo_model_weights(list(loo_list[[1]])), "At least two models") - expect_error(loo_model_weights(list(log_lik1), method = "pseudobma"), "At least two models") + expect_error( + loo_model_weights(list(log_lik1), method = "pseudobma"), + "At least two models" + ) - expect_error(loo_model_weights(list(log_lik1, log_lik2[-1, ])), "same dimensions") - expect_error(loo_model_weights(list(log_lik1, log_lik2, log_lik3[, -1])), "same dimensions") + expect_error( + loo_model_weights(list(log_lik1, log_lik2[-1, ])), + "same dimensions" + ) + expect_error( + loo_model_weights(list(log_lik1, log_lik2, log_lik3[, -1])), + "same dimensions" + ) loo_list2 <- loo_list attr(loo_list2[[3]], "dims") <- c(10, 10) expect_error(loo_model_weights(loo_list2), "same dimensions") - expect_error(loo_model_weights(ll_list, r_eff_list = r_eff_list[-1]), - "one component for each model") + expect_error( + loo_model_weights(ll_list, r_eff_list = r_eff_list[-1]), + "one component for each model" + ) r_eff_list[[3]] <- rep(0.9, 51) - expect_error(loo_model_weights(ll_list, r_eff_list = r_eff_list), - "same length as the number of columns") + expect_error( + loo_model_weights(ll_list, r_eff_list = r_eff_list), + "same length as the number of columns" + ) - expect_error(loo_model_weights(list(loo_list[[1]], 2)), - "List elements must all be 'psis_loo' objects or log-likelihood matrices", - fixed = TRUE) + expect_error( + loo_model_weights(list(loo_list[[1]], 2)), + "List elements must all be 'psis_loo' objects or log-likelihood matrices", + fixed = TRUE + ) expect_no_warning(loo_model_weights(ll_list)) }) @@ -54,34 +72,54 @@ test_that("loo_model_weights throws correct errors and warnings", { test_that("loo_model_weights (stacking and pseudo-BMA) gives expected result", { w1 <- loo_model_weights(ll_list, method = "stacking", r_eff_list = r_eff_list) - expect_type(w1,"double") + expect_type(w1, "double") expect_s3_class(w1, "stacking_weights") expect_length(w1, 3) - expect_named(w1, paste0("model" ,c(1:3))) - expect_equal_to_reference(as.numeric(w1), "reference-results/model_weights_stacking.rds", - tolerance = tol, scale=1) + expect_named(w1, paste0("model", c(1:3))) + expect_equal_to_reference( + as.numeric(w1), + "reference-results/model_weights_stacking.rds", + tolerance = tol, + scale = 1 + ) expect_output(print(w1), "Method: stacking") w1_b <- loo_model_weights(loo_list) expect_identical(w1, w1_b) - w2 <- loo_model_weights(ll_list, r_eff_list=r_eff_list, - method = "pseudobma", BB = TRUE) + w2 <- loo_model_weights( + ll_list, + r_eff_list = r_eff_list, + method = "pseudobma", + BB = TRUE + ) expect_type(w2, "double") expect_s3_class(w2, "pseudobma_bb_weights") expect_length(w2, 3) expect_named(w2, paste0("model", c(1:3))) - expect_equal_to_reference(as.numeric(w2), "reference-results/model_weights_pseudobma.rds", - tolerance = tol, scale=1) + expect_equal_to_reference( + as.numeric(w2), + "reference-results/model_weights_pseudobma.rds", + tolerance = tol, + scale = 1 + ) expect_output(print(w2), "Method: pseudo-BMA+") - w3 <- loo_model_weights(ll_list, r_eff_list=r_eff_list, - method = "pseudobma", BB = FALSE) - expect_type(w3,"double") + w3 <- loo_model_weights( + ll_list, + r_eff_list = r_eff_list, + method = "pseudobma", + BB = FALSE + ) + expect_type(w3, "double") expect_length(w3, 3) - expect_named(w3, paste0("model" ,c(1:3))) - expect_equal(as.numeric(w3), c(5.365279e-05, 9.999436e-01, 2.707028e-06), - tolerance = tol, scale = 1) + expect_named(w3, paste0("model", c(1:3))) + expect_equal( + as.numeric(w3), + c(5.365279e-05, 9.999436e-01, 2.707028e-06), + tolerance = tol, + scale = 1 + ) expect_output(print(w3), "Method: pseudo-BMA") w3_b <- loo_model_weights(loo_list, method = "pseudobma", BB = FALSE) @@ -112,4 +150,3 @@ test_that("loo_model_weights uses correct names for list of loo objects", { c("a", "b", "c") ) }) - diff --git a/tests/testthat/test_pointwise.R b/tests/testthat/test_pointwise.R index 237304c3..bd66bb78 100644 --- a/tests/testthat/test_pointwise.R +++ b/tests/testthat/test_pointwise.R @@ -29,8 +29,14 @@ test_that("pointwise throws the right errors", { test_that("pointwise returns correct estimate", { expect_equal(pointwise(loo1, "elpd_loo"), loo1$pointwise[, "elpd_loo"]) - expect_equal(pointwise(loo1, "mcse_elpd_loo"), loo1$pointwise[, "mcse_elpd_loo"]) + expect_equal( + pointwise(loo1, "mcse_elpd_loo"), + loo1$pointwise[, "mcse_elpd_loo"] + ) expect_equal(pointwise(loo1, "p_loo"), loo1$pointwise[, "p_loo"]) expect_equal(pointwise(loo1, "looic"), loo1$pointwise[, "looic"]) - expect_equal(pointwise(loo1, "influence_pareto_k"), loo1$pointwise[, "influence_pareto_k"]) + expect_equal( + pointwise(loo1, "influence_pareto_k"), + loo1$pointwise[, "influence_pareto_k"] + ) }) diff --git a/tests/testthat/test_print_plot.R b/tests/testthat/test_print_plot.R index a81b4af4..f3ec5eb9 100644 --- a/tests/testthat/test_print_plot.R +++ b/tests/testthat/test_print_plot.R @@ -29,26 +29,42 @@ test_that("plot methods throw appropriate errors/warnings", { loo1$diagnostics$pareto_k[1:5] <- Inf psis1$diagnostics$pareto_k[1:5] <- Inf - expect_warning(plot(loo1), regexp = "estimates are Inf/NA/NaN and not plotted.") - expect_warning(plot(psis1), regexp = "estimates are Inf/NA/NaN and not plotted.") + expect_warning( + plot(loo1), + regexp = "estimates are Inf/NA/NaN and not plotted." + ) + expect_warning( + plot(psis1), + regexp = "estimates are Inf/NA/NaN and not plotted." + ) }) - # printing ---------------------------------------------------------------- -lldim_msg <- paste0("Computed from ", prod(dim(LLarr)[1:2]) , " by ", - dim(LLarr)[3], " log-likelihood matrix") -lwdim_msg <- paste0("Computed from ", prod(dim(LLarr)[1:2]) , " by ", - dim(LLarr)[3], " log-weights matrix") - -test_that("print.waic output is ok",{ +lldim_msg <- paste0( + "Computed from ", + prod(dim(LLarr)[1:2]), + " by ", + dim(LLarr)[3], + " log-likelihood matrix" +) +lwdim_msg <- paste0( + "Computed from ", + prod(dim(LLarr)[1:2]), + " by ", + dim(LLarr)[3], + " log-weights matrix" +) + +test_that("print.waic output is ok", { expect_output(print(waic1), lldim_msg) - expect_output(print(waic1), + expect_output( + print(waic1), "p_waic estimates greater than 0.4. We recommend trying loo instead." ) }) -test_that("print.psis_loo and print.psis output ok",{ +test_that("print.psis_loo and print.psis output ok", { expect_output(print(psis1), lwdim_msg) expect_output(print(psis1), "Pareto k estimates are good") expect_output(print(loo1), lldim_msg) @@ -82,13 +98,23 @@ test_that("pareto_k_influence_values works for psis_loo objects, errors for psis kloo2 <- pareto_k_values(loo1) expect_identical(kloo, kloo2) - expect_error(pareto_k_influence_values(psis1), "No Pareto k influence estimates found") - expect_error(pareto_k_influence_values(waic1), "No Pareto k influence estimates found") + expect_error( + pareto_k_influence_values(psis1), + "No Pareto k influence estimates found" + ) + expect_error( + pareto_k_influence_values(waic1), + "No Pareto k influence estimates found" + ) }) test_that("pareto_k_ids identifies correct observations", { for (j in 1:5) { - loo1$diagnostics$pareto_k <- psis1$diagnostics$pareto_k <- runif(32, .25, 1.25) + loo1$diagnostics$pareto_k <- psis1$diagnostics$pareto_k <- runif( + 32, + .25, + 1.25 + ) expect_identical( pareto_k_ids(loo1, threshold = 0.5), pareto_k_ids(psis1, threshold = 0.5) @@ -107,7 +133,7 @@ test_that("pareto_k_ids identifies correct observations", { test_that("pareto_k_table gives correct output", { threshold <- ps_khat_threshold(dim(psis1)[1]) psis1$diagnostics$pareto_k[1:10] <- runif(10, 0, threshold) - psis1$diagnostics$pareto_k[11:20] <- runif(10, threshold+0.01, 0.99) + psis1$diagnostics$pareto_k[11:20] <- runif(10, threshold + 0.01, 0.99) psis1$diagnostics$pareto_k[21:32] <- runif(12, 1, 10) k <- pareto_k_values(psis1) tab <- pareto_k_table(psis1) @@ -117,9 +143,9 @@ test_that("pareto_k_table gives correct output", { expect_equal(sum(tab[, "Count"]), length(k)) expect_equal(sum(tab[, "Proportion"]), 1) - expect_equal(sum(k <= threshold), tab[1,1]) - expect_equal(sum(k > threshold & k <= 1), tab[2,1]) - expect_equal(sum(k > 1), tab[3,1]) + expect_equal(sum(k <= threshold), tab[1, 1]) + expect_equal(sum(k > threshold & k <= 1), tab[2, 1]) + expect_equal(sum(k > 1), tab[3, 1]) # if n_eff is NULL psis1$diagnostics$n_eff <- NULL @@ -128,13 +154,14 @@ test_that("pareto_k_table gives correct output", { expect_equal(unname(tab2[, "Min. n_eff"]), rep(NA_real_, 3)) psis1$diagnostics$pareto_k[1:32] <- 0.4 - expect_output(print(pareto_k_table(psis1)), - paste0("All Pareto k estimates are good (k < ", round(threshold,2), ")"), - fixed = TRUE) + expect_output( + print(pareto_k_table(psis1)), + paste0("All Pareto k estimates are good (k < ", round(threshold, 2), ")"), + fixed = TRUE + ) }) - # psis_neff and mcse_loo -------------------------------------------------- test_that("psis_n_eff_values extractor works", { n_eff_psis <- psis1$diagnostics$n_eff @@ -161,4 +188,3 @@ test_that("mcse_loo returns NA when it should", { test_that("mcse_loo errors if not psis_loo object", { expect_error(mcse_loo(psis1), "psis_loo") }) - diff --git a/tests/testthat/test_psis.R b/tests/testthat/test_psis.R index ef4b14cd..62f052a4 100644 --- a/tests/testthat/test_psis.R +++ b/tests/testthat/test_psis.R @@ -1,6 +1,6 @@ library(loo) -options(mc.cores=1) -options(loo.cores=NULL) +options(mc.cores = 1) +options(loo.cores = NULL) set.seed(123) context("psis") @@ -48,12 +48,12 @@ test_that("psis throws correct errors and warnings", { # r_eff=NULL no warnings expect_silent(psis(-LLarr, r_eff = NULL)) expect_silent(psis(-LLmat, r_eff = NULL)) - expect_silent(psis(-LLmat[,1], r_eff = NULL)) + expect_silent(psis(-LLmat[, 1], r_eff = NULL)) # r_eff=NA disables warnings expect_silent(psis(-LLarr, r_eff = NA)) expect_silent(psis(-LLmat, r_eff = NA)) - expect_silent(psis(-LLmat[,1], r_eff = NA)) + expect_silent(psis(-LLmat[, 1], r_eff = NA)) # r_eff default and r_eff=NA give same answer expect_equal( @@ -63,7 +63,7 @@ test_that("psis throws correct errors and warnings", { # r_eff=NULL and r_eff=NA give same answer expect_equal( - suppressWarnings(psis(-LLarr, r_eff=NULL)), + suppressWarnings(psis(-LLarr, r_eff = NULL)), psis(-LLarr, r_eff = NA) ) @@ -79,15 +79,15 @@ test_that("psis throws correct errors and warnings", { # tail length warnings expect_warning( - psis(-LLarr[1:5,, ]), + psis(-LLarr[1:5, , ]), "Not enough tail samples to fit the generalized Pareto distribution" ) # no NAs or non-finite values allowed - LLmat[1,1] <- NA + LLmat[1, 1] <- NA expect_error(psis(-LLmat), "NAs not allowed in input") - LLmat[1,1] <- 1 + LLmat[1, 1] <- 1 LLmat[10, 2] <- -Inf expect_error(psis(-LLmat), "All input values must be finite or -Inf") # log ratio of -Inf is allowed @@ -95,7 +95,10 @@ test_that("psis throws correct errors and warnings", { expect_no_error(psis(-LLmat)) # no lists allowed - expect_error(expect_warning(psis(as.list(-LLvec))), "List not allowed as input") + expect_error( + expect_warning(psis(as.list(-LLvec))), + "List not allowed as input" + ) # if array, must be 3-D array dim(LLarr) <- c(2, 250, 2, 32) @@ -110,10 +113,11 @@ test_that("throw_tail_length_warnings gives correct output", { expect_silent(throw_tail_length_warnings(10)) expect_equal(throw_tail_length_warnings(10), 10) expect_warning(throw_tail_length_warnings(1), "Not enough tail samples") - expect_warning(throw_tail_length_warnings(c(1, 10, 2)), - "Skipping the following columns: 1, 3") - expect_warning(throw_tail_length_warnings(rep(1, 21)), - "11 more not printed") + expect_warning( + throw_tail_length_warnings(c(1, 10, 2)), + "Skipping the following columns: 1, 3" + ) + expect_warning(throw_tail_length_warnings(rep(1, 21)), "11 more not printed") }) @@ -146,8 +150,11 @@ test_that("psis_n_eff methods works properly", { test_that("do_psis_i throws warning if all tail values the same", { - xx <- c(1,2,3,4,4,4,4,4,4,4,4) - val <- expect_warning(do_psis_i(xx, tail_len_i = 6), "all tail values are the same") + xx <- c(1, 2, 3, 4, 4, 4, 4, 4, 4, 4, 4) + val <- expect_warning( + do_psis_i(xx, tail_len_i = 6), + "all tail values are the same" + ) expect_equal(val$pareto_k, Inf) }) @@ -155,9 +162,8 @@ test_that("psis_smooth_tail returns original tail values if k is infinite", { # skip on M1 Mac until we figure out why this test fails only on M1 Mac skip_if(Sys.info()[["sysname"]] == "Darwin" && R.version$arch == "aarch64") - xx <- c(1,2,3,4,4,4,4,4,4,4,4) + xx <- c(1, 2, 3, 4, 4, 4, 4, 4, 4, 4, 4) val <- suppressWarnings(psis_smooth_tail(xx, 3)) expect_equal(val$tail, xx) expect_equal(val$k, Inf) }) - diff --git a/tests/testthat/test_psis_approximate_posterior.R b/tests/testthat/test_psis_approximate_posterior.R index 0529d0f4..0edbae46 100644 --- a/tests/testthat/test_psis_approximate_posterior.R +++ b/tests/testthat/test_psis_approximate_posterior.R @@ -10,14 +10,25 @@ test_that("Laplace approximation, independent posterior", { ll <- test_data_psis_approximate_posterior$laplace_independent$log_liks expect_silent( psis_lap <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_lap, "psis") expect_lt(pareto_k_values(psis_lap), 0.7) expect_silent( psis_lap_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_lap_ll, "loo") expect_true(all(pareto_k_values(psis_lap_ll) < 0.7)) @@ -30,14 +41,25 @@ test_that("Laplace approximation, correlated posterior", { ll <- test_data_psis_approximate_posterior$laplace_correlated$log_liks expect_silent( psis_lap <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_lap, "psis") expect_lt(pareto_k_values(psis_lap), 0.7) expect_silent( psis_lap_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_lap_ll, "loo") expect_true(all(pareto_k_values(psis_lap_ll) < 0.7)) @@ -49,35 +71,56 @@ test_that("Laplace approximation, normal model", { ll <- test_data_psis_approximate_posterior$laplace_normal$log_liks expect_no_warning( psis_lap <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_lap, "psis") expect_gt(pareto_k_values(psis_lap), 0.5) expect_warning( psis_lap_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_lap_ll, "loo") expect_true(all(pareto_k_values(psis_lap_ll) > 0.5)) }) - test_that("ADVI fullrank approximation, independent posterior", { log_p <- test_data_psis_approximate_posterior$fullrank_independent$log_p log_g <- test_data_psis_approximate_posterior$fullrank_independent$log_q ll <- test_data_psis_approximate_posterior$fullrank_independent$log_liks expect_silent( psis_advi <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi, "psis") expect_lt(pareto_k_values(psis_advi), 0.7) expect_silent( psis_advi_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi_ll, "loo") expect_true(all(pareto_k_values(psis_advi_ll) < 0.7)) @@ -90,14 +133,25 @@ test_that("ADVI fullrank approximation, correlated posterior", { ll <- test_data_psis_approximate_posterior$fullrank_correlated$log_liks expect_silent( psis_advi <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi, "psis") expect_lt(pareto_k_values(psis_advi), 0.7) expect_silent( psis_advi_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi_ll, "loo") expect_true(all(pareto_k_values(psis_advi_ll) < 0.7)) @@ -109,14 +163,25 @@ test_that("ADVI fullrank approximation, correlated posterior", { ll <- test_data_psis_approximate_posterior$fullrank_normal$log_liks expect_warning( psis_advi <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi, "psis") expect_gt(pareto_k_values(psis_advi), 0.7) expect_warning( psis_advi_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi_ll, "loo") expect_true(all(pareto_k_values(psis_advi_ll) > 0.7)) @@ -129,14 +194,25 @@ test_that("ADVI meanfield approximation, independent posterior", { ll <- test_data_psis_approximate_posterior$meanfield_independent$log_liks expect_silent( psis_advi <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi, "psis") expect_lt(pareto_k_values(psis_advi), 0.7) expect_silent( psis_advi_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi_ll, "loo") expect_true(all(pareto_k_values(psis_advi_ll) < 0.7)) @@ -149,14 +225,25 @@ test_that("ADVI meanfield approximation, correlated posterior", { ll <- test_data_psis_approximate_posterior$meanfield_correlated$log_liks expect_warning( psis_advi <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi, "psis") expect_gt(pareto_k_values(psis_advi), 0.7) expect_warning( psis_advi_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi_ll, "loo") expect_true(all(pareto_k_values(psis_advi_ll) > 0.5)) @@ -169,14 +256,25 @@ test_that("ADVI meanfield approximation, normal model", { ll <- test_data_psis_approximate_posterior$meanfield_normal$log_liks expect_warning( psis_advi <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi, "psis") expect_gt(pareto_k_values(psis_advi), 0.7) expect_warning( psis_advi_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi_ll, "loo") expect_true(all(pareto_k_values(psis_advi_ll) > 0.7)) @@ -184,20 +282,30 @@ test_that("ADVI meanfield approximation, normal model", { test_that("ADVI meanfield approximation, normal model", { - log_p <- test_data_psis_approximate_posterior$meanfield_normal$log_p log_g <- test_data_psis_approximate_posterior$meanfield_normal$log_q ll <- test_data_psis_approximate_posterior$meanfield_normal$log_liks expect_warning( psis_advi <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi, "psis") expect_gt(pareto_k_values(psis_advi), 0.7) expect_warning( psis_advi_ll <- - psis_approximate_posterior(log_p = log_p, log_g = log_g, log_liks = ll , cores = 1, save_psis = FALSE) + psis_approximate_posterior( + log_p = log_p, + log_g = log_g, + log_liks = ll, + cores = 1, + save_psis = FALSE + ) ) expect_s3_class(psis_advi_ll, "loo") expect_true(all(pareto_k_values(psis_advi_ll) > 0.7)) @@ -205,14 +313,18 @@ test_that("ADVI meanfield approximation, normal model", { test_that("Deprecation of log_q argument", { - log_p <- test_data_psis_approximate_posterior$laplace_independent$log_p log_g <- test_data_psis_approximate_posterior$laplace_independent$log_q ll <- test_data_psis_approximate_posterior$laplace_independent$log_liks expect_warning( psis_lap <- - loo:::psis_approximate_posterior(log_p = log_p, log_q = log_g, cores = 1, save_psis = FALSE) - , regexp = "argument log_q has been changed to log_g" + loo:::psis_approximate_posterior( + log_p = log_p, + log_q = log_g, + cores = 1, + save_psis = FALSE + ), + regexp = "argument log_q has been changed to log_g" ) expect_s3_class(psis_lap, "psis") expect_lt(pareto_k_values(psis_lap), 0.7) diff --git a/tests/testthat/test_psislw.R b/tests/testthat/test_psislw.R index fb339751..0f9f4d98 100644 --- a/tests/testthat/test_psislw.R +++ b/tests/testthat/test_psislw.R @@ -49,19 +49,24 @@ test_that("psislw function and matrix methods return same result", { set.seed(024) # fake data and posterior draws - N <- 50; K <- 10; S <- 100; a0 <- 3; b0 <- 2 + N <- 50 + K <- 10 + S <- 100 + a0 <- 3 + b0 <- 2 p <- rbeta(1, a0, b0) y <- rbinom(N, size = K, prob = p) - a <- a0 + sum(y); b <- b0 + N * K - sum(y) + a <- a0 + sum(y) + b <- b0 + N * K - sum(y) draws <- rbeta(S, a, b) - data <- data.frame(y,K) + data <- data.frame(y, K) llfun <- function(i, data, draws) { dbinom(data$y, size = data$K, prob = draws, log = TRUE) } psislw_with_fn <- SW(psislw(llfun = llfun, llargs = nlist(data, draws, N, S))) # Check that we get same answer if using log-likelihood matrix - ll <- sapply(1:N, function(i) llfun(i, data[i,, drop=FALSE], draws)) + ll <- sapply(1:N, function(i) llfun(i, data[i, , drop = FALSE], draws)) psislw_with_mat <- SW(psislw(-ll)) expect_equal(psislw_with_fn, psislw_with_mat) }) @@ -69,8 +74,12 @@ test_that("psislw function and matrix methods return same result", { test_that("psislw_warnings helper works properly", { k <- c(0, 0.1, 0.55, 0.75) expect_silent(psislw_warnings(k[1:2])) - expect_warning(psislw_warnings(k[1:3]), - "Some Pareto k diagnostic values are slightly high") - expect_warning(psislw_warnings(k), - "Some Pareto k diagnostic values are too high") + expect_warning( + psislw_warnings(k[1:3]), + "Some Pareto k diagnostic values are slightly high" + ) + expect_warning( + psislw_warnings(k), + "Some Pareto k diagnostic values are too high" + ) }) diff --git a/tests/testthat/test_relative_eff.R b/tests/testthat/test_relative_eff.R index 800c08b8..4e09757c 100644 --- a/tests/testthat/test_relative_eff.R +++ b/tests/testthat/test_relative_eff.R @@ -8,15 +8,18 @@ LLarr <- example_loglik_array() LLmat <- example_loglik_matrix() test_that("relative_eff results haven't changed", { - expect_equal_to_reference(relative_eff(exp(LLarr)), "reference-results/relative_eff.rds") + expect_equal_to_reference( + relative_eff(exp(LLarr)), + "reference-results/relative_eff.rds" + ) }) test_that("relative_eff is equal to ESS / S", { dims <- dim(LLarr) ess <- r_eff <- rep(NA, dims[3]) for (j in 1:dims[3]) { - r_eff[j] <- relative_eff(LLarr[,,1, drop=FALSE]) - ess[j] <- ess_rfun(LLarr[,,1]) + r_eff[j] <- relative_eff(LLarr[,, 1, drop = FALSE]) + ess[j] <- ess_rfun(LLarr[,, 1]) } S <- prod(dim(LLarr)[1:2]) expect_equal(r_eff, ess / S) @@ -32,7 +35,13 @@ test_that("relative_eff matrix and function methods return identical output", { source(test_path("data-for-tests/function_method_stuff.R")) chain <- rep(1, nrow(draws)) r_eff_mat <- relative_eff(llmat_from_fn, chain_id = chain) - r_eff_fn <- relative_eff(llfun, chain_id = chain, data = data, draws = draws, cores = 1) + r_eff_fn <- relative_eff( + llfun, + chain_id = chain, + data = data, + draws = draws, + cores = 1 + ) expect_identical(r_eff_mat, r_eff_fn) }) diff --git a/tests/testthat/test_tisis.R b/tests/testthat/test_tisis.R index 5d693a37..182c0cd9 100644 --- a/tests/testthat/test_tisis.R +++ b/tests/testthat/test_tisis.R @@ -1,6 +1,6 @@ library(loo) -options(mc.cores=1) -options(loo.cores=NULL) +options(mc.cores = 1) +options(loo.cores = NULL) set.seed(123) context("tis and is") @@ -25,7 +25,6 @@ test_that("tis and is runs", { }) test_that("tis() and sis() returns object with correct structure for tis/sis", { - expect_false(is.psis(tis1)) expect_false(is.psis(is1)) expect_true(is.tis(tis1)) @@ -77,7 +76,6 @@ test_that("psis methods give same results", { }) - test_that("tis throws correct errors and warnings", { # r_eff default no warnings expect_silent(tis(-LLarr)) @@ -87,23 +85,23 @@ test_that("tis throws correct errors and warnings", { # r_eff=NULL no warnings expect_silent(tis(-LLarr, r_eff = NULL)) expect_silent(tis(-LLmat, r_eff = NULL)) - expect_silent(tis(-LLmat[,1], r_eff = NULL)) + expect_silent(tis(-LLmat[, 1], r_eff = NULL)) # r_eff=NA no warnings expect_silent(tis(-LLarr, r_eff = NA)) expect_silent(tis(-LLmat, r_eff = NA)) - expect_silent(tis(-LLmat[,1], r_eff = NA)) + expect_silent(tis(-LLmat[, 1], r_eff = NA)) # r_eff default and r_eff=NA give same answer expect_equal( suppressWarnings(tis(-LLarr)), - tis(-LLarr, r_eff = NA) + tis(-LLarr, r_eff = NA) ) # r_eff=NULL and r_eff=NA give same answer expect_equal( suppressWarnings(tis(-LLarr, r_eff = NULL)), - tis(-LLarr, r_eff = NA) + tis(-LLarr, r_eff = NA) ) # r_eff scalar is fine @@ -117,17 +115,20 @@ test_that("tis throws correct errors and warnings", { expect_error(tis(-LLarr, r_eff = r_eff_arr), "mix NA and not NA values") # no NAs or non-finite values allowed - LLmat[1,1] <- NA + LLmat[1, 1] <- NA expect_error(tis(-LLmat), "NAs not allowed in input") - LLmat[1,1] <- 1 + LLmat[1, 1] <- 1 LLmat[10, 2] <- -Inf expect_error(tis(-LLmat), "All input values must be finite or -Inf") LLmat[10, 2] <- Inf expect_no_error(tis(-LLmat)) # no lists allowed - expect_error(expect_warning(tis(as.list(-LLvec)), "List not allowed as input")) + expect_error(expect_warning( + tis(as.list(-LLvec)), + "List not allowed as input" + )) # if array, must be 3-D array dim(LLarr) <- c(2, 250, 2, 32) @@ -142,21 +143,73 @@ test_that("tis throws correct errors and warnings", { test_that("explict test of values for 'sis' and 'tis'", { lw <- 1:16 expect_silent(tis_true <- tis(log_ratios = lw, r_eff = NA)) - expect_equal(as.vector(weights(tis_true, log = TRUE, normalize = FALSE)), - c(-14.0723, -13.0723, -12.0723, -11.0723, -10.0723, -9.0723, -8.0723, -7.0723, -6.0723, -5.0723, -4.0723, -3.0723, -2.0723, -1.0723, -0.0723, 0.) + 15.07238, tol = 0.001) + expect_equal( + as.vector(weights(tis_true, log = TRUE, normalize = FALSE)), + c( + -14.0723, + -13.0723, + -12.0723, + -11.0723, + -10.0723, + -9.0723, + -8.0723, + -7.0723, + -6.0723, + -5.0723, + -4.0723, + -3.0723, + -2.0723, + -1.0723, + -0.0723, + 0. + ) + + 15.07238, + tol = 0.001 + ) expect_silent(is_true <- sis(log_ratios = lw, r_eff = NA)) - expect_equal(as.vector(weights(is_true, log = TRUE, normalize = FALSE)), - lw, tol = 0.00001) + expect_equal( + as.vector(weights(is_true, log = TRUE, normalize = FALSE)), + lw, + tol = 0.00001 + ) - lw <- c(0.7609420, 1.3894140, 0.4158346, 2.5307927, 4.3379119, 2.4159240, 2.2462172, 0.8057697, 0.9333107, 1.5599302) + lw <- c( + 0.7609420, + 1.3894140, + 0.4158346, + 2.5307927, + 4.3379119, + 2.4159240, + 2.2462172, + 0.8057697, + 0.9333107, + 1.5599302 + ) expect_silent(tis_true <- tis(log_ratios = lw, r_eff = NA)) - expect_equal(as.vector(weights(tis_true, log = TRUE, normalize = FALSE)), - c(-2.931, -2.303, -3.276, -1.161, 0, -1.276, -1.446, -2.886, -2.759, -2.132) + 3.692668, - tol = 0.001) + expect_equal( + as.vector(weights(tis_true, log = TRUE, normalize = FALSE)), + c( + -2.931, + -2.303, + -3.276, + -1.161, + 0, + -1.276, + -1.446, + -2.886, + -2.759, + -2.132 + ) + + 3.692668, + tol = 0.001 + ) expect_silent(is_true <- sis(log_ratios = lw, r_eff = NA)) - expect_equal(as.vector(weights(is_true, log = TRUE, normalize = FALSE)), - lw, tol = 0.00001) + expect_equal( + as.vector(weights(is_true, log = TRUE, normalize = FALSE)), + lw, + tol = 0.00001 + ) })