R/methods.R

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

#' Print object returned by \code{restrict}
#'
#' @author Mattan S. Ben-Shachar
#' @param BFE an object returned by restrict
#' @param logBF should BF be presented as log(BF)? (defult, FALSE)
#' @param digits Number of digist to round numeric data.
#'
#' @export
print.resBF <- function(BFE, logBF = options()$BFE.print_logBF, digits = 3) {
  # Print probabilities
  writeLines('Restricted Model Probabilities:')
  probs <- round(BFE$probability, digits = digits)
  rownames(probs) <- 'Probability:'
  colnames(probs) <- c('Prior','Posterior')
  print.data.frame(probs)
  writeLines('\n')

  # Print BFs
  res_BFs <- BFE$`log(BFs)`

  # Make a matrix of BFs with colnames representing the numerator and
  # rows are the denominator
  BFMAT <- matrix(nrow = 3,ncol = 3)
  rownames(BFMAT) <- colnames(BFMAT) <- c('Restricted','Full','Null')
  diag(BFMAT) <- 0
  BFMAT[upper.tri(BFMAT)] <- -1*t(res_BFs)[c(1,3,2)]
  BFMAT[lower.tri(BFMAT)] <- t(res_BFs)[c(1,3,2)]

  if (!logBF) {
    writeLines('BFs:')
    print(round(exp(BFMAT),digits = digits))
  } else {
    writeLines('log(BF)s:')
    print(round(BFMAT,digits = digits))
  }
  writeLines('---\ncolumns are the numerator and rows are the denominator')
  invisible(BFE)
}

#' Print object returned by \code{inferBF}
#'
#' @author Mattan S. Ben-Shachar
#' @param BFE an object returned by \code{inferBF}
#' @param logBF should BFs be presented as \code{log(BF)}?
#' @param digits Number of digist to round numeric data.
#' @param showSpec Show hypotheses specifications
#'
#' @import purrr
print.inferBF <- function(BFE,logBF = options()$BFE.print_logBF,digits = 3,showSpec = FALSE) {
  is_est <- map_lgl(BFE,~any(colnames(.x)=='Estimate'))

  writeLines('Hypotheses tested based on the model:')
  writeLines(paste0('\t',attr(BFE,'model')))

  # directed
  if (any(!is_est)) {
    dirs <- reduce(BFE[!is_est],rbind)
    dirs <- round(dirs,digits = digits)
    if (logBF) {
      dirs[1:3] <- log(dirs[1:3])
      colnames(dirs)[1:3] <- paste0('log(',colnames(dirs)[1:3],')')
    }

    writeLines('\nDirectional Tests:')
    print.data.frame(dirs)
  }

  # point
  if (any(is_est)) {
    ests <- reduce(BFE[is_est],rbind)
    ests <- round(ests,digits = digits)
    if (logBF) {
      ests$BF <- log(ests$BF)
      colnames(ests)[5] <- 'log(BF)'
    }
    writeLines('\nPoint Tests:')
    print.data.frame(ests)
    writeLines(paste0('---\nHDI level: ', attr(BFE,'level')))
    writeLines('Point BF calculated using the Savage-Dickey method')
  }

  if (showSpec) {
    writeLines('\n')
    spec <- as.data.frame(attr(BFE,'hyp'))
    colnames(spec) <- 'Hypothesis.specification'
    print.data.frame(spec)
  }

  invisible(BFE)
}

#' Convert object returned by \code{inferBF} to a \code{data.frame}
#'
#' @author Mattan S. Ben-Shachar
#' @param BFE an object returned by \code{inferBF}
#' @param type Which test type should be returned. Partial matching accepted.
#'
#' @export
#' @import dplyr
#' @import purrr
as.data.frame.inferBF <- function(BFE, type = c('both','point','direction')){
  type <- match.arg(type[1],c('both','point','directional'))

  is_est <- map_lgl(BFE,~any(colnames(.x)=='Estimate'))
  model_types <- if (type=='point') {
    is_est
  } else if (type=='directional') {
    !is_est
  } else {
    c(which(is_est),which(!is_est))
  }

  BFE %>%
    map2(attr(BFE,'hyp'),
         ~mutate(.x,
                 Hypothesis = .y,
                 Type = ifelse('Estimate' %in% colnames(.x),"Point","Directional"))) %>%
    .[model_types] %>%
    bind_rows(.id = "Test") %>%
    select(Type,Test,Hypothesis,everything()) %>%
    arrange(desc(Type))
}

#' Print object returned by \code{hyp}
#'
#' @author Mattan S. Ben-Shachar
#' @param BFE an object returned by \code{hyp}
#'
#' @importFrom purrr map_chr
#' @importFrom rlang quo_name
print.hypBF <- function(BFE){
  if (length(BFE)==1) {
    writeLines('One Hypothesis:')
  } else {
    writeLines(paste0(length(BFE),' Hypotheses:'))
  }
  spec <- as.data.frame(map_chr(BFE,quo_name))
  colnames(spec) <- 'Hypothesis specification'
  print.data.frame(spec)

  invisible(BFE)
}