R/tidy_summarise.R

Defines functions column_ci summarise_posterior summarise_samples

Documented in column_ci summarise_posterior summarise_samples

#' Create a tidy data frame of summarized posterior samples
#'
#' @param model a \code{\link[rstan]{stanfit}} object
#' @inheritParams summarise_posterior
#' @inheritParams column_ci
#' @param log_prob whether to include the log probability values
#' @return A \code{\link[dplyr]{data_frame}} where each row is one sample of
#'         one variable.
#'
#' @examples
#' library(rstanarm)
#' model <- stan_glm(kid_score ~ mom_hs + mom_iq + mom_age,
#'                   data = kidiq, iter = 500, chains = 1)
#' summarise_samples(model$stanfit, func = c("mean", "median"),
#'                   conf_level = c(0.5, 0.9))
#'
#' @export
summarise_samples <- function(model, func = "mean", conf_level = 0.9,
															log_prob = FALSE) {
	param_list <- rstan::extract(model)

	if (!log_prob) {
		param_list <- param_list[names(param_list) != "lp__"]
	}

	param_list <- lapply(param_list, summarise_posterior,
											 func = func, conf_level = conf_level)

	param_tibble <- tibble::tibble(parameter = names(param_list),
																estimates = param_list) %>%
		tidyr::unnest(estimates)

	param_tibble
}

#' Convert a vector of posterior sample to a dataframe
#'
#' @param x a vector or matrix of posterior samples for some parameter
#' @inheritParams column_ci
#' @param func the summary functions to evaluate, as a character vector
#' @return A \code{\link[tibble]{tibble}} where each row is one sample of
#'         one parameter, with a column for which draw the sample came from (`draw`)
#'         and a column for which index of the parameter the draw is for (`i`).
#'         (For this case, the function is always )
#'
#' @export
summarise_posterior <- function(x, func = "mean", conf_level = 0.9) {
	if (!is.matrix(x)) x <- matrix(x, ncol = 1)

	# Compute the confidence intervals
	ci <- column_ci(x, conf_level)

	# Compute the summary values
	summary_values <- lapply(func, function(f) apply(x, 2, get(f)))
	names(summary_values) <- func

	cbind(tibble::tibble(i = 1:ncol(x)),
				tibble::as_tibble(summary_values),
				tibble::as_tibble(ci))
}

#' Compute the confidence intervals of the columns based on quantiles
#'
#' @param x the matrix
#' @param conf_level the confidence levels to report confidence intervals in.
#' Set as NULL to have no confidence intervals.
#'
#' @export
column_ci <- function(x, conf_level) {
	ci_probs <- c((1 - conf_level) / 2, (1 + conf_level) / 2)
	ci <- apply(x, 2, quantile, probs = ci_probs) %>% t()
	colnames(ci) <- vapply(ci_probs, function(x) paste0("ci_", as.character(x)), "")
	ci
}
wjones127/tidystan documentation built on May 28, 2017, 4:36 a.m.