R/restrict.R

In mattansb/BFEffect: Analyse models and effects estimated with BayesFactor

#' Compute BFs for restricted models
#'
#' Compute BFs for restricted models
#'
#' @author Mattan S. Ben-Shachar
#' @param BF an object returned by any of the BayesFactor modeling functions
#' @param ... \code{dplyr::filter}-like logical arguments by which the model will be restricted.
#' @param .index which BF mddel to test?
#' @param .iterations how many posterior iterations?
#' @param .prior the prior probability of the restricted model. If not speficied, will be estimated.
#' @param .niceNames whould the coeff names be a little nicer?
#'
#' @return A list with two data.frames:
#'  \enumerate{
#'   \item \code{probability} - containing the prior and posterior probabilities.
#'   \item \code{log(BFs)} - containing the log of the BFs for the model.
#' }
#'
#' @export
#' @import dplyr
#' @import purrr
#' @import stringr
restrict <- function(BF, ..., .index = 1, .iterations = 10000, .prior = NULL, .niceNames = TRUE) {
  BF <- BF[.index]
  crit <- quos(...)

  # Get model posteriors
  posts <- as.data.frame(posterior(BF,iterations = .iterations,progress = FALSE))
  priors <- sample_from_priors(BF,posts)

  # Make nice (readable) names
  if (.niceNames) {
    priors <- nicify_names(priors)
    posts <- nicify_names(posts)
  }

  # If not ciriteria, just list the paramaters
  if (length(crit) == 0) {
    return(names(posts))
  }

  # Get post and prior prob
  p.post <- nrow(filter(posts,!!!crit))/.iterations
  p.prior <- nrow(filter(priors,!!!crit))/.iterations


  BF_restricted.full <- log(p.post / p.prior)
  BF_full.null       <- extractBF(BF, TRUE, TRUE)
  BF_restricted.null <- BF_restricted.full + BF_full.null

  BF.r_list <- list(probability = data.frame(prior     = p.prior,
                                             posterior = p.post),
                    `log(BFs)` = data.frame(restricted.full = BF_restricted.full,
                                            full.null       = BF_full.null,
                                            restricted.null = BF_restricted.null))
  attr(BF.r_list,'class') <- c('resBF','BFEffect','list')

  return(BF.r_list)
}