R/inferBF-utility.R

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

#' @import dplyr
#' @import stringr
sample_from_priors <- function(BF, post_samples, index = 1){
  BF <- BF[index]
  # mm <- model.matrix(BF)
  prior_samples <- post_samples

  rFixed <- BF@numerator[[1]]@prior$rscale$fixed
  rContinuous <- BF@numerator[[1]]@prior$rscale$continuous
  rRandom <- BF@numerator[[1]]@prior$rscale$random
  rEffects <- BF@numerator[[1]]@prior$rscale$effects

  if (length(rEffects)!=0) {
    warning('Using rscaleFixed/rscaleContinuous instead of custom rscaleEffect when sampling priors')
  }

  dataTypes <- attributes(BF)[["numerator"]][[1]]@dataTypes
  varsFixed <- names(dataTypes)[dataTypes=="fixed"]
  varsContinuous <- names(dataTypes)[dataTypes=="continuous"]
  varsRandom <- names(dataTypes)[dataTypes=="random"]

  eff_names <- colnames(prior_samples)

  if (length(varsFixed)!=0) {
    prior_samples <- prior_samples %>%
      mutate_if(
        str_detect_any(eff_names,varsFixed) & !str_detect(eff_names,'^g_'),
        ~rcauchy(n(), scale = rFixed/sqrt(2))
      )
  }

  if (length(varsContinuous)!=0) {
    prior_samples <- prior_samples %>%
      mutate_if(
        str_detect_any(eff_names,varsContinuous) & !str_detect(eff_names,'^g_'),
        ~rcauchy(n(), scale = rContinuous)
      )
    for (iv in varsContinuous) {
      prior_samples <- prior_samples %>%
        mutate_if(
          str_detect_any(eff_names,iv) & !str_detect(eff_names,'^g_'),
          ~(./sd(BF@data[,iv])))
    }
  }

  if (length(varsRandom)!=0) {
    prior_samples <- prior_samples %>%
      mutate_if(
        str_detect_any(eff_names,varsRandom) & !str_detect(eff_names,'^g_'),
        ~rcauchy(n(), scale = rRandom)
      )
  }

  prior_samples <- prior_samples %>%
    mutate_if(
      .predicate = str_detect_any(eff_names,names(dataTypes)),
      .funs = ~(.*sqrt(prior_samples$sig2))
    )

  prior_samples
}

str_detect_any <- function(string, pattern) {
  purrr::map_lgl(string,~any(stringr::str_detect(.x,pattern)))
}


get_dfun <- function(X) {
  if (all(X>0)) {
    ls <- logspline::logspline(X,lbound = 0)
  } else if (all(X<0)) {
    ls <- logspline::logspline(X,ubound = 0)
  } else {
    ls <- logspline::logspline(X)
  }
  partial(logspline::dlogspline,fit = ls)
}