Nothing
#' Print methods
#'
#' @export
#' @param x An object returned by [loo()], [psis()], or [waic()].
#' @param digits An integer passed to [base::round()].
#' @param plot_k Logical. If `TRUE` the estimates of the Pareto shape
#' parameter \eqn{k} are plotted. Ignored if `x` was generated by
#' [waic()]. To just plot \eqn{k} without printing use the
#' [plot()][pareto-k-diagnostic] method for 'loo' objects.
#' @param ... Arguments passed to [plot.psis_loo()] if `plot_k` is
#' `TRUE`.
#'
#' @return `x`, invisibly.
#'
#' @seealso [pareto-k-diagnostic]
#'
print.loo <- function(x, digits = 1, ...) {
cat("\n")
print_dims(x)
if (!("estimates" %in% names(x))) {
x <- convert_old_object(x)
}
cat("\n")
print(.fr(as.data.frame(x$estimates), digits), quote = FALSE)
return(invisible(x))
}
#' @export
#' @rdname print.loo
print.waic <- function(x, digits = 1, ...) {
print.loo(x, digits = digits, ...)
throw_pwaic_warnings(x$pointwise[, "p_waic"], digits = digits, warn = FALSE)
invisible(x)
}
#' @export
#' @rdname print.loo
print.psis_loo <- function(x, digits = 1, plot_k = FALSE, ...) {
print.loo(x, digits = digits, ...)
cat("------\n")
print_mcse_summary(x, digits = digits)
if (length(pareto_k_ids(x, threshold = 0.5))) {
cat("\n")
}
print(pareto_k_table(x), digits = digits)
cat(.k_help())
if (plot_k) {
graphics::plot(x, ...)
}
invisible(x)
}
#' @export
#' @rdname print.loo
print.importance_sampling_loo <- function(x, digits = 1, plot_k = FALSE, ...) {
print.loo(x, digits = digits, ...)
cat("------\n")
invisible(x)
}
#' @export
#' @rdname print.loo
print.psis_loo_ap <- function(x, digits = 1, plot_k = FALSE, ...) {
print.loo(x, digits = digits, ...)
cat("------\n")
cat("Posterior approximation correction used.\n")
print_mcse_summary(x, digits = digits)
if (length(pareto_k_ids(x, threshold = 0.5))) {
cat("\n")
}
print(pareto_k_table(x), digits = digits)
cat(.k_help())
if (plot_k) {
graphics::plot(x, ...)
}
invisible(x)
}
#' @export
#' @rdname print.loo
print.psis <- function(x, digits = 1, plot_k = FALSE, ...) {
print_dims(x)
print(pareto_k_table(x), digits = digits)
cat(.k_help())
if (plot_k) {
graphics::plot(x, ...)
}
invisible(x)
}
#' @export
#' @rdname print.loo
print.importance_sampling <- function(x, digits = 1, plot_k = FALSE, ...) {
print_dims(x)
if (plot_k) {
graphics::plot(x, ...)
}
invisible(x)
}
# internal ----------------------------------------------------------------
#' Print dimensions of log-likelihood or log-weights matrix
#'
#' @export
#' @keywords internal
#'
#' @param x The object returned by [psis()], [loo()], or [waic()].
#' @param ... Ignored.
print_dims <- function(x, ...) UseMethod("print_dims")
#' @rdname print_dims
#' @export
print_dims.importance_sampling <- function(x, ...) {
cat(
"Computed from",
paste(dim(x), collapse = " by "),
"log-weights matrix\n"
)
}
#' @rdname print_dims
#' @export
print_dims.psis_loo <- function(x, ...) {
cat(
"Computed from",
paste(dim(x), collapse = " by "),
"log-likelihood matrix\n"
)
}
#' @rdname print_dims
#' @export
print_dims.importance_sampling_loo <- function(x, ...) {
cat(
"Computed from",
paste(dim(x), collapse = " by "),
"log-likelihood matrix using", class(x)[1], "\n"
)
}
#' @rdname print_dims
#' @export
print_dims.waic <- function(x, ...) {
cat(
"Computed from",
paste(dim(x), collapse = " by "),
"log-likelihood matrix\n"
)
}
#' @rdname print_dims
#' @export
print_dims.kfold <- function(x, ...) {
K <- attr(x, "K", exact = TRUE)
if (!is.null(K)) {
cat("Based on", paste0(K, "-fold"), "cross-validation\n")
}
}
#' @rdname print_dims
#' @export
print_dims.psis_loo_ss <- function(x, ...) {
cat(
"Computed from",
paste(c(dim(x)[1], nobs(x)) , collapse = " by "),
"subsampled log-likelihood\nvalues from",
length(x$loo_subsampling$elpd_loo_approx),
"total observations.\n"
)
}
print_mcse_summary <- function(x, digits) {
mcse_val <- mcse_loo(x)
cat(
"Monte Carlo SE of elpd_loo is",
paste0(.fr(mcse_val, digits), ".\n")
)
}
# print and warning helpers
.fr <- function(x, digits) format(round(x, digits), nsmall = digits)
.warn <- function(..., call. = FALSE) warning(..., call. = call.)
.k_help <- function() "See help('pareto-k-diagnostic') for details.\n"
# compatibility with old loo objects
convert_old_object <- function(x, digits = 1, ...) {
z <- x[-grep("pointwise|pareto_k|n_eff", names(x))]
uz <- unlist(z)
nms <- names(uz)
ses <- grepl("se", nms)
list(estimates = data.frame(Estimate = uz[!ses], SE = uz[ses]))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.