In michael-franke/faintr: Factor Interpreter for Bayesian Regression Models

knitr::opts_chunk$set(
  echo = TRUE, 
  warning = FALSE,
  message = FALSE, 
  collapse = TRUE,
  comment = "#>",
  fig.path = "man/figures/README-",
  out.width = "100%"
)

library(faintr)
library(brms)
library(posterior)
library(dplyr)
library(tidyr)
library(ggplot2)
library(aida)

theme_set(theme_bw() + theme(plot.background = element_blank()))

custom_palette <- c("#009E73", "#B22222", "#0072B2", "#D55E00")

scale_colour_discrete <- function(...) {
  scale_colour_manual(..., values = custom_palette)
}
scale_fill_discrete <- function(...) {
   scale_fill_manual(..., values = custom_palette)
}

faintr

Overview

The faintr (FActorINTerpreteR) package provides convenience functions for interpreting brms model fits for data from factorial designs. It allows for the extraction and comparison of posterior draws for a given design cell, irrespective of the encoding scheme used in the model.

Currently, faintr provides the following functions:

get_cell_definitions returns information on the predictor variables and how they are encoded in the model.
extract_cell_draws returns posterior draws and additional metadata for all design cells.
filter_cell_draws returns posterior draws and additional metadata for one subset of design cells.
compare_groups returns summary statistics of comparing two subsets of design cells.

Installation

You can install the development version from GitHub with:

# install.packages("devtools")
devtools::install_github("michael-franke/faintr")

Examples

In this section, we shortly introduce how to use the package. For a more detailed overview, please refer to the vignette.

We will use a preprocessed version of the mouse-tracking data set from the aida package:

data <- aida::data_MT

data <- data %>% 
  mutate(
    prototype_label = case_when(
      prototype_label %in% c('curved', 'straight') ~ prototype_label,
      TRUE ~ 'CoM'
      ),
    prototype_label = factor(prototype_label,
                             levels = c('straight', 'curved', 'CoM')))

data %>% 
  select(RT, group, condition, prototype_label) %>%
  head()

The variables relevant for us are:

RT: Reaction time in milliseconds
group: Whether a category is selected by click vs touch
condition: Whether the animal is a typical vs atypical representative of its category
prototype_label: The type of prototypical movement strategy (straight vs curved vs CoM)

Below, we regress the log-transformed reaction times as a function of factors group, condition, prototype_label, and their three-way interaction using a linear regression model fitted with brms:

fit <- brms::brm(formula = log(RT) ~ group * condition * prototype_label,
                 data = data,
                 seed = 123
                 )

To obtain information on the factors and the coding scheme used in the model, we can use get_cell_definitions:

get_cell_definitions(fit)

The output shows that factors group, condition and prototype_label are dummy-coded, with click, Atypical, and straight being the reference levels, respectively.

To extract posterior draws for all design cells, we can use extract_cell_draws:

extract_cell_draws(fit)

With filter_cell_draws we can obtain posterior draws for a specific design cell. For instance, draws for typical exemplars in click trials, averaged over factor prototype_label, can be extracted like so:

filter_cell_draws(fit, condition == "Typical" & group == "click")

Parameter colname allows changing the default column name in the output, which facilitates post-processing of cell draws, e.g., for plotting or summary statistics. Here, we extract the draws for each level of prototype_label (averaged over group and condition) and visualize the results:

draws_straight <- filter_cell_draws(fit, prototype_label == "straight", colname = "straight")
draws_curved <- filter_cell_draws(fit, prototype_label == "curved", colname = "curved")
draws_CoM <- filter_cell_draws(fit, prototype_label == "CoM", colname = "CoM")

draws_prototype <- posterior::bind_draws(draws_straight, draws_curved, draws_CoM) %>%
  pivot_longer(cols = posterior::variables(.), names_to = "prototype", values_to = "value")

draws_prototype %>%
  ggplot(aes(x = value, color = prototype, fill = prototype)) +
  geom_density(alpha = 0.4)

Finally, we can compare two subsets of design cells with compare_groups. Here, we compare the estimates for atypical exemplars in click trials against typical exemplars in click trials (averaged over the three prototypical movement strategies):

compare_groups(fit,
               higher = condition == "Atypical" & group == "click",
               lower = condition == "Typical" & group == "click"
               )

If one of two group specifications is left out, we compare against the grand mean:

compare_groups(fit,
               higher = group == "click"
               )

If the Boolean flag include_bf is set to TRUE (default is FALSE), Bayes Factors for the inequality (higher > lower) are approximated in comparison to the "negated hypothesis" (lower <= higher). However, this requires specifying proper priors for all parameters:

fit_with_priors <- brms::brm(formula = log(RT) ~ group * condition * prototype_label,
                             prior = prior(student_t(1, 0, 3), class = "b"),
                             data = data,
                             seed = 123
                             )

compare_groups(fit_with_priors,
               higher = prototype_label != "straight",
               lower = prototype_label == "straight",
               include_bf = TRUE
               )