Stat's What It's All About

Exploring {ggplot2}’s Geoms and Stats

Sun, 14 Sep 2025 21:00:00 GMT

Code

Working with Ordinal Ranks in {marginaleffects}

Wed, 30 Apr 2025 21:00:00 GMT

Given an ordinal regression model, it is relatively easy to get class-wise predictions - the conditional predicted probability of each level of the outcome. However, often, one might be interested in summarizing effects not on the class-wise probability scale (nor on the latent scale), but instead on the rank scale - the expected ordinal level, expressed as a single number.

The {emmeans} package has the mode = "mean.class" that does just this.

Let’s see how we can do this in {marginaleffects} by utilizing the powerful hypothesis= argument.

Fit a model

library(tidyverse)

library(marginaleffects)

bfi <- psych::bfi |> 
  mutate(
    gender = factor(gender),
    A1 = ordered(A1)
  ) |> 
  drop_na(A1, age, gender)

nrow(bfi)
#> [1] 2784

fit <- MASS::polr(A1 ~ age + gender, 
                  data = bfi,
                  Hess = TRUE)

Class-Wise Predictions

pr1 <- predictions(fit, variables = "gender")
pr1
#> 
#>  Group Estimate Std. Error     z Pr(>|z|)     S   2.5 % 97.5 %
#>      1   0.1800    0.01136 15.85   <0.001 185.5 0.15777 0.2023
#>      1   0.1886    0.01128 16.71   <0.001 205.9 0.16649 0.2107
#>      1   0.1843    0.01132 16.28   <0.001 195.6 0.16210 0.2065
#>      1   0.1843    0.01132 16.28   <0.001 195.6 0.16210 0.2065
#>      1   0.1843    0.01132 16.28   <0.001 195.6 0.16210 0.2065
#> --- 33398 rows omitted. See ?print.marginaleffects --- 
#>      6   0.0289    0.00335  8.64   <0.001 57.3 0.02234 0.0355
#>      6   0.0231    0.00264  8.78   <0.001 59.1 0.01798 0.0283
#>      6   0.0219    0.00250  8.76   <0.001 58.8 0.01699 0.0268
#>      6   0.0207    0.00238  8.71   <0.001 58.1 0.01604 0.0254
#>      6   0.0121    0.00165  7.35   <0.001 42.2 0.00891 0.0154
#> Type:  probs

nrow(pr1) # original data * 2 (counterfactual gender) * 6 (levels of A1)
#> [1] 33408

For each observation in the original data frame we now have 12 predictions:
- 2 counterfactual predictions for the two levels of gender, times
- 6 (arguably also counterfactual) predictions for each of the possible outcome levels.

Sum-scores (mean rank)

We can average the class ranks by their predicted probability to obtain “sum scores”:

And we can do this for each row in the counterfactual data frame (marked by the rowidcf variable):

sum_score <- function(x) {
  x |> 
    arrange(rowidcf, group, gender) |> 
    # for each counterfactual row and level of gender
    summarise(
      term = "sum score",
      estimate = sum(estimate * (1:6)), 
      
      .by = c(rowidcf, gender)
    )
}

pr2 <- predictions(fit, variables = "gender", 
                   hypothesis = sum_score)
pr2
#> 
#>  Estimate Std. Error    z Pr(>|z|)   S 2.5 % 97.5 %
#>      3.02     0.0583 51.8   <0.001 Inf  2.90   3.13
#>      2.51     0.0451 55.6   <0.001 Inf  2.42   2.60
#>      2.97     0.0553 53.7   <0.001 Inf  2.86   3.08
#>      2.46     0.0415 59.4   <0.001 Inf  2.38   2.55
#>      3.00     0.0568 52.8   <0.001 Inf  2.88   3.11
#> --- 5558 rows omitted. See ?print.marginaleffects --- 
#>      2.24     0.0305 73.4   <0.001   Inf  2.18   2.30
#>      2.67     0.0473 56.4   <0.001   Inf  2.57   2.76
#>      2.20     0.0304 72.2   <0.001   Inf  2.14   2.26
#>      2.26     0.0645 35.0   <0.001 890.8  2.13   2.38
#>      1.85     0.0457 40.6   <0.001   Inf  1.77   1.94
#> Term: sum score
#> Type:  probs

nrow(pr2) # original data * 2 (counterfactual gender)
#> [1] 5568

As expected, we now have 2 predictions for each observation in the original data frame: - 2 counterfactual predictions for the two levels of gender

Note that we could have also computed the mean rank for the two levels of gender, or literally anything else. But here I am trying to mimic the basic behavior of the avg_/comparisons() functions by keeping with the workflow:

Compute observation wise counterfactual predictions
Contrast them for each observation
(Possibly) average them

So let’s get those contrasts!

Contrast the ranks

sum_score.contr <- function(x) {
  # same as before, and...
  sum_score(x) |> 
    # compute a single contrast for each counterfactual row
    summarise(
      term = "gender (2-1)",
      estimate = estimate[gender == "2"] - estimate[gender == "1"], 
      
      .by = rowidcf
    )
}

This function will compute a difference between the rank for each gender for each observation.

pr3 <- predictions(fit, variables = "gender", 
                   hypothesis = sum_score.contr)
pr3
#> 
#>  Estimate Std. Error     z Pr(>|z|)    S  2.5 % 97.5 %
#>    -0.511     0.0588 -8.68   <0.001 57.8 -0.626 -0.395
#>    -0.506     0.0584 -8.67   <0.001 57.7 -0.621 -0.392
#>    -0.509     0.0586 -8.68   <0.001 57.8 -0.623 -0.394
#>    -0.509     0.0586 -8.68   <0.001 57.8 -0.623 -0.394
#>    -0.509     0.0586 -8.68   <0.001 57.8 -0.623 -0.394
#> --- 2774 rows omitted. See ?print.marginaleffects --- 
#>    -0.504     0.0582 -8.67   <0.001 57.6 -0.618 -0.390
#>    -0.483     0.0560 -8.62   <0.001 57.1 -0.593 -0.373
#>    -0.477     0.0554 -8.61   <0.001 56.9 -0.586 -0.368
#>    -0.471     0.0548 -8.59   <0.001 56.7 -0.578 -0.363
#>    -0.403     0.0488 -8.26   <0.001 52.6 -0.499 -0.307
#> Term: gender (2-1)
#> Type:  probs

nrow(pr3) # original data
#> [1] 2784

Average Contrast

Finally, we can get the average difference:

# average contrast 
avg_sum_score.contr <- function(x) {
  sum_score.contr(x) |> 
    summarise(
      term = "avg. gender (2-1)",
      estimate = mean(estimate)
    )
}

predictions(fit, variables = "gender", 
            hypothesis = avg_sum_score.contr)
#> 
#>  Estimate Std. Error     z Pr(>|z|)    S  2.5 % 97.5 %
#>    -0.474     0.0551 -8.61   <0.001 56.9 -0.582 -0.366
#> 
#> Term: avg. gender (2-1)
#> Type:  probs

POMP

POMP (percent of maximum possible) are a for of standardized units for Likert-type items (see Solomon Kurz’s excellent blog post for more – better – info).

These are linear transformations of the ranks described above:

We can obtain POMPs for each row in the counterfactual data frame by further processing the sum-scores:

POMP <- function(x) {
  sum_score(x) |> 
    mutate(
      estimate = 100 * (estimate - 1) / (6 - 1)
    )
}

predictions(fit, variables = "gender", 
            hypothesis = POMP)
#> 
#>  Estimate Std. Error    z Pr(>|z|)     S 2.5 % 97.5 %
#>      40.4      1.166 34.6   <0.001 870.6  38.1   42.7
#>      30.2      0.902 33.5   <0.001 812.8  28.4   31.9
#>      39.4      1.107 35.6   <0.001 920.9  37.3   41.6
#>      29.3      0.829 35.3   <0.001 905.5  27.7   30.9
#>      39.9      1.135 35.1   <0.001 896.3  37.7   42.1
#> --- 5558 rows omitted. See ?print.marginaleffects --- 
#>      24.7      0.609 40.6   <0.001   Inf  23.5   25.9
#>      33.3      0.945 35.3   <0.001 902.9  31.5   35.2
#>      23.9      0.608 39.3   <0.001   Inf  22.7   25.1
#>      25.2      1.289 19.5   <0.001 279.4  22.6   27.7
#>      17.1      0.914 18.7   <0.001 256.9  15.3   18.9
#> Term: sum score
#> Type:  probs

And likewise get contrasts -

POMP.contr <- function(x) {
  POMP(x) |> 
    summarise(
      term = "gender (2-1)",
      estimate = estimate[gender == "2"] - estimate[gender == "1"], 
      
      .by = rowidcf
    )
}

predictions(fit, variables = "gender", 
            hypothesis = sum_score.contr)
#> 
#>  Estimate Std. Error     z Pr(>|z|)    S  2.5 % 97.5 %
#>    -0.511     0.0588 -8.68   <0.001 57.8 -0.626 -0.395
#>    -0.506     0.0584 -8.67   <0.001 57.7 -0.621 -0.392
#>    -0.509     0.0586 -8.68   <0.001 57.8 -0.623 -0.394
#>    -0.509     0.0586 -8.68   <0.001 57.8 -0.623 -0.394
#>    -0.509     0.0586 -8.68   <0.001 57.8 -0.623 -0.394
#> --- 2774 rows omitted. See ?print.marginaleffects --- 
#>    -0.504     0.0582 -8.67   <0.001 57.6 -0.618 -0.390
#>    -0.483     0.0560 -8.62   <0.001 57.1 -0.593 -0.373
#>    -0.477     0.0554 -8.61   <0.001 56.9 -0.586 -0.368
#>    -0.471     0.0548 -8.59   <0.001 56.7 -0.578 -0.363
#>    -0.403     0.0488 -8.26   <0.001 52.6 -0.499 -0.307
#> Term: gender (2-1)
#> Type:  probs

And average contrasts -

# average contrast 
avg_POMP.contr <- function(x) {
  POMP.contr(x) |> 
    summarise(
      term = "avg. gender (2-1)",
      estimate = mean(estimate)
    )
}

predictions(fit, variables = "gender", 
            hypothesis = avg_POMP.contr)
#> 
#>  Estimate Std. Error     z Pr(>|z|)    S 2.5 % 97.5 %
#>     -9.49        1.1 -8.61   <0.001 56.9 -11.6  -7.33
#> 
#> Term: avg. gender (2-1)
#> Type:  probs

A note for Bayesians

Hey, Bayesians, how are you doing?

I have some bad news: {marginaleffects} does not support hypothesis=.

But I also have some good news! You can basically do all of this by getting the posterior draws in an rvar format, and then directly manipulating the posterior(s) - so the examples above should basically work out of the box.

For example:

library(brms)
library(posterior)

fit_b <- brm(A1 ~ age + gender, 
             data = bfi,
             family = cumulative(),
             prior = NULL) # obviously this is a bad prior

pr1_b <- predictions(fit_b, variables = "gender")

We just need to adapt the function(s) written above to work properly with rvars. I’ve marked

avg_POMP.contr_b <- function(x) {
  x |> 
    arrange(rowidcf, group, gender) |> 
    # for each counterfactual row and level of gender
    summarise(
      term = "sum score",
      # estimate = sum(estimate * (1:6)), 
1      estimate = rvar_sum(rvar * (1:6)),
      
      .by = c(rowidcf, gender)
    ) |> 
    # POMP
    mutate(
      estimate = 100 * (estimate - 1) / (6 - 1)
    ) |> 
    # contrasts
    summarise(
      term = "gender (2-1)",
      estimate = estimate[gender == "2"] - estimate[gender == "1"], 
      
      .by = rowidcf
    ) |> 
    # average
    summarise(
      term = "avg. gender (2-1)",
      # estimate = mean(estimate)
2      estimate = rvar_mean(estimate)
    )
}

1: Use the rvar column and the rvar_sum() function (instead of sum())
2: Use the rvar_mean() function (instead of mean())

get_draws(pr1_b, shape = "rvar") |>
  avg_POMP.contr_b()
#>                term   estimate
#> 1 avg. gender (2-1) -9.4 ± 1.1

Compare this to the frequentists estimate of -9.49, SE = 1.10 we got above.

Centering in Moderation Analysis: A Guide

Sat, 20 Jan 2024 22:00:00 GMT

This blog post will cover what centering is, what a sum-to-zero contrast is, why and when you should use them, and how you can do them in R. Specifically, we will focus on their use and how they affect coefficient interpretation in regression tables and affect interpretation in ANOVA tables.

I will be using the following packages and versions:

library(datawizard) # 0.9.1
library(parameters) # 0.21.3

We will be using the following toy data set:

Generate Toy Dataset

Order Constraints in Bayes Models (with brms)

Sun, 25 Jun 2023 21:00:00 GMT

Over a year ago, while listing to a very not-at-all-statistical podcast, I discovered that Bayesian modeling is widely used in archaeology since the mid 90s to calibrate carbon dating.¹

Carbon dating is a scientific method used to determine the age of ancient artifacts and archaeological remains. It relies on the natural decay of a radioactive isotope called carbon-14, which is present in all living organisms. By measuring the amount of carbon-14 present in a sample, scientists can estimate its age with remarkable precision, over spans of thousands of years.

How do archaeologists calibrate carbon dating with Bayesian models? One way is by applying order constraints to their models.

In this post I will present what order constraints are, and how we may assess and apply them in Bayesian models using the {brms} package (Bürkner, 2017). I assume the reader is already somewhat familiar with the {brms} package, Bayesian modeling and core concepts in MCMC sampling.

I will be using the following packages and versions:

library(tidyverse)  # 2.0.0
library(scales)     # 1.2.1
library(insight)    # 0.19.2
library(brms)       # 2.19.0
library(posterior)  # 1.4.1.9000
library(ggdist)     # 3.3.0
library(tidybayes)  # 3.0.4
library(bayestestR) # 0.13.1

You will need the most recent development version of {posterior} for some of the code presented in this post. You can install it from GitHub by running the following:

remotes::install_github("stan-dev/posterior")

Options and Constants

Ordinal Regression as a Model for Signal Detection

Wed, 05 Oct 2022 21:00:00 GMT

Preface

I was basically done with this blog post when I came across Matti Vuorre’s post on the same exact topic. Matti goes into all the details, and really the present post can be seen as a brief account of all the cool things the probit-approach-to-SDT can do. I’m only posting this here because I really like my plots 🤷

Previously, we’ve seen that for data from a binary decision signal detection task, we can use a probit binomial regression model (like a logistic regression, but with a probit link function) to estimate the two main parameters of signal detection theory (SDT): the sensitivity and the bias.

In this post I would like to show how this idea can be extended to multiple response SDT tasks by using an ordinal probit regression model.

The Data

Imagine the following task: after being presented with 20 images of dogs, you are presented with 300 new images of dogs, and you have to decide for each dog if it appeared in the training set (“Old”) or not (“New”).

In a binary decision task, you would simply indicate “New” or “Old”, but in this task you have multiple response options - from 1 to 6, with 1 = “Feels New” and 6 = “Feels Old”. We can call this scale a “feelings numbers” scale.

After going over all 30 photos, you have

STD_data

# A tibble: 12 × 3
   Truth Response        N
           
 1 New   Confidence1    35
 2 New   Confidence2    31
 3 New   Confidence3    26
 4 New   Confidence4    22
 5 New   Confidence5    19
 6 New   Confidence6    17
 7 Old   Confidence1    14
 8 Old   Confidence2    20
 9 Old   Confidence3    22
10 Old   Confidence4    27
11 Old   Confidence5    32
12 Old   Confidence6    35

Where N is the number of responses in each condition and response level.

Modeling with Classic SDT

We can use Siegfried Macho’s R code to extract the SDT parameters. In this case, they are:

Sensitivity - The distance between the two (latent) normal distributions. The further they are, the more “distinguishable” the Old and New images are from each other.
5 Threshold - One between each pair of consecutive possible responses. Perceived “stimulation” above each threshold leads to a decision in that category.

(These will probably make sense when we present them visually below.)

First, we’ll model this with classical SDT:

SDT_equal <- SDT.Estimate(
  data = STD_data[["N"]],
  test = TRUE,
  # We have 2 option: Old / New; We'll assume equal variance
  n = list(n.sdt = 2, restriction = "equalvar")
) 

SDT.Statistics(SDT_equal)[["Free.parameters"]]

         Value    SE CFI-95(Lower) CFI-95(Upper)
Mean[2]  0.564 0.040         0.486         0.642
t-1     -0.744 0.034        -0.810        -0.678
t-2     -0.165 0.031        -0.226        -0.104
t-3      0.267 0.031         0.206         0.329
t-4      0.707 0.033         0.643         0.772
t-5      1.260 0.036         1.189         1.331

Modeling as a Probit Cumulative Ordinal

library(dplyr)      # 1.1.4
library(tidyr)      # 1.3.0
library(ordinal)    # 2022.11.16
library(parameters) # 0.21.3
library(ggplot2)    # 3.4.4
library(patchwork)  # 1.1.3

We can also model this data with a Probit Cumulative Ordinal model, predicting the Response from the Truth: - The slope of Truth indicates the effect of the true image identity had on the response pattern - this is sensitivity.
- In an ordinal model, we get k-1 “intercepts” (k being the number of unique responses). Each intercept represents the value above which a predicted value will be binned into the next class. There represent our shreshold.

m_equal <- clm(Response ~ Truth, 
  data = STD_data,
  weights = N,
  link = "probit"
)

parameters::model_parameters(m_equal) |> 
  insight::print_html()

Model Summary
Parameter	Coefficient	SE	95% CI	z	p
Intercept
Confidence1\|Confidence2	-0.74	0.10	(-0.94, -0.54)	-7.21	< .001
Confidence2\|Confidence3	-0.16	0.10	(-0.35, 0.02)	-1.72	0.085
Confidence3\|Confidence4	0.27	0.10	(0.08, 0.46)	2.81	0.005
Confidence4\|Confidence5	0.71	0.10	(0.51, 0.90)	7.08	< .001
Confidence5\|Confidence6	1.26	0.11	(1.05, 1.48)	11.38	< .001
Location Parameters
Truth (Old)	0.57	0.12	(0.33, 0.81)	4.65	< .001

As we can see, the estimated values are identical!¹

The advantage of the probit ordinal model is that it is easy(er) to build this model up:

Add predictors of sensitivity (interactions with Truth)
Add predictors of bias (main effects / intercept effects)
Add random effects (with ordinal::clmm())

(See Matti’s post for actual examples!)

mean2 <- coef(m_equal)[6]

Thresholds <- coef(m_equal)[1:5]

ggplot() + 
  # Noise
  stat_function(aes(linetype = "Noise"), fun = dnorm,
                linewidth = 1) + 
  # Noise + Signal
  stat_function(aes(linetype = "Noise + Signal"), fun = dnorm, 
                args = list(mean = mean2),
                linewidth = 1) + 
  # Thresholds
  geom_vline(aes(xintercept = Thresholds, color = names(Thresholds)),
             linewidth = 2) + 
  scale_color_brewer("Threshold", type = "div", palette = 2,
                     labels = paste0(1:5, " | ", 2:6)) + 
  labs(y = NULL, linetype = NULL, x = "Obs. signal") + 
  expand_limits(x = c(-3, 3), y = 0.45) + 
  theme_classic()

Unequal Variance

The standard model of SDT assumes that the Noise and the Noise + Signal distribution differ only in their mean; that is, N+S is a shifted N distribution. This is almost always not true, with .

To deal with this, we can also estimate the variance of the N+S distribution.

First, with the classic SDT model:

SDT_unequal <- SDT.Estimate(
  data = STD_data[["N"]],
  test = TRUE,
  # We have 2 option: Old / New; Not assuming equal variance
  n = list(n.sdt = 2, restriction = "no")
) 

SDT.Statistics(SDT_unequal)[["Free.parameters"]]

           Value    SE CFI-95(Lower) CFI-95(Upper)
Mean[2]    0.552 0.041         0.473         0.632
Stddev[2]  0.960 0.035         0.891         1.029
t-1       -0.728 0.036        -0.799        -0.658
t-2       -0.159 0.032        -0.221        -0.097
t-3        0.266 0.031         0.205         0.327
t-4        0.696 0.034         0.629         0.763
t-5        1.235 0.043         1.151         1.318

And with a probit ordinal regression, but allow the latent scale to vary:

m_unequal <- clm(Response ~ Truth, 
  scale = ~ Truth, # We indicate that the scale is a function of the underlying dist
  data = STD_data, 
  weights = N,
  link = "probit"
)

parameters::model_parameters(m_unequal) |> 
  insight::print_html()

Model Summary
Parameter	Coefficient	SE	95% CI	z	p
Intercept
Confidence1\|Confidence2	-0.72	0.11	(-0.93, -0.50)	-6.51	< .001
Confidence2\|Confidence3	-0.16	0.10	(-0.34, 0.03)	-1.61	0.107
Confidence3\|Confidence4	0.27	0.10	(0.08, 0.45)	2.80	0.005
Confidence4\|Confidence5	0.69	0.10	(0.49, 0.90)	6.66	< .001
Confidence5\|Confidence6	1.23	0.13	(0.98, 1.49)	9.50	< .001
Location Parameters
Truth (Old)	0.55	0.12	(0.31, 0.80)	4.49	< .001
Scale Parameters
Truth (Old)	-0.05	0.12	(0.31, 0.80)	4.49	< .001

The scale parameter needs to be back transformed to get the sd of the N+S distribution: , and so one again the estimated values are identical!

mean2 <- coef(m_unequal)[6]
sd2 <- exp(coef(m_unequal)[7])

Thresholds <- coef(m_unequal)[1:5]

ggplot() + 
  # Noise
  stat_function(aes(linetype = "Noise"), fun = dnorm,
                linewidth = 1) + 
  # Noise + Signal
  stat_function(aes(linetype = "Noise + Signal"), fun = dnorm, 
                args = list(mean = mean2, sd = sd2),
                linewidth = 1) + 
  # Thresholds
  geom_vline(aes(xintercept = Thresholds, color = names(Thresholds)),
             linewidth = 2) + 
  scale_color_brewer("Threshold", type = "div", palette = 2,
                     labels = paste0(1:5, " | ", 2:6)) + 
  labs(y = NULL, linetype = NULL, x = "Obs. signal") + 
  expand_limits(x = c(-3, 3), y = 0.45) + 
  theme_classic()

SDT with N and N+S distributions, and the 5 thresholds.

ROC Curve or ROC Curves?

An additional check we can preform is whether the various responses are indeed the product of single ROC curve. We do this by plotting the ROC curve on a inv-normal transformation (that is, converting probabilities into normal quantiles). Quantiles that fall on a straight line indicate they are part of the same curve.

pred_table <- data.frame(Truth = c("Old", "New")) |> 
  mutate(predict(m_unequal, newdata = pick(everything()), type = "prob")[[1]] |> as.data.frame()) |> 
  tidyr::pivot_longer(starts_with("Confidence"), names_to = "Response") |> 
  tidyr::pivot_wider(names_from = Truth)

ROC_table <- pred_table |> 
  mutate(
    Sensitivity = lag(cumsum(New), default = 0),
    Specificity = rev(cumsum(rev(Old))),
  ) |> 
  # Some clean up...
  rows_append(data.frame(Sensitivity = 1, Specificity = 0)) |> 
  mutate(
    Threshold = c(NA, paste0(1:5, "|", 2:6), NA)
  )

p_roc <- ggplot(ROC_table, aes(Sensitivity, Specificity)) + 
  geom_line() + 
  geom_abline(slope = 1, intercept = 1, linetype = "dashed") + 
  geom_point(aes(color = ordered(Threshold)), size = 2) + 
  expand_limits(x = c(0,1), y = c(0,1)) +
  scale_x_continuous(trans = "reverse") +
  scale_color_brewer("Threshold", type = "div", palette = 2,
                     labels = paste0(1:5, " | ", 2:6),
                     na.translate = FALSE) + 
  labs(color = NULL) + 
  theme_classic()

p_zroc <- ROC_table |> 
  ggplot(aes(qnorm(Sensitivity), qnorm(Specificity))) + 
  geom_line() + 
  geom_point(aes(color = ordered(Threshold)), size = 2) + 
  expand_limits(x = c(0,1), y = c(0,1)) +
  scale_x_continuous(trans = "reverse") +
  scale_color_brewer("Threshold", type = "div", palette = 2,
                     labels = paste0(1:5, " | ", 2:6),
                     na.translate = FALSE) + 
  labs(color = NULL, x = "Z(Sensitivity)", y = "Z(Specificity)") + 
  theme_classic()

p_roc + p_zroc + plot_layout(guides = "collect")

Warning: Removed 2 rows containing missing values (`geom_point()`).
Removed 2 rows containing missing values (`geom_point()`).

Because the point (on the Z-scale) fall on a straight line, we can confidently say they represent the same ROC curve.

Going Full Bayesian

Although the clmm() function allows for multilevel probit regression, it does not² support varying scale parameter.

Alas, we must use brms.

library(brms)      # 2.20.4
library(ggdist)    # 3.3.1.9000
library(tidybayes) # 3.0.6

In brms we will use the cumulative() family, which has a family-parameter called disc which gives the standard deviation of the latent distributions. I will set some weak priors on the mean and standard deviation of the N+S distribution, and I will also set the standard deviation of the N distribution to 1 (on a log scale, to 0) using the constant(0) prior.

b_formula <- bf(Response | weights(N) ~ Truth,
                disc ~ 0 + Intercept + Truth)
b_priors <- 
  set_prior("normal(0, 3)", coef = "TruthOld") + 
  set_prior("normal(0, 1.5)", coef = "TruthOld", dpar = "disc") + 
  set_prior("constant(0)", coef = "Intercept", dpar = "disc")


Bayes_mod <- brm(b_formula,
  prior = b_priors,
  family = cumulative(link = "probit", link_disc = "log"),
  data = STD_data,
  backend = "cmdstanr",
  refresh = 0
)

model_parameters(Bayes_mod, test = NULL) |> 
  insight::print_html()

Model Summary
Parameter	Median	95% CI	Rhat	ESS
Intercept(1)	-0.74	(-0.95, -0.52)	1.000	2799.00
Intercept(2)	-0.16	(-0.36, 0.03)	1.000	4556.00
Intercept(3)	0.27	(0.08, 0.46)	1.000	5326.00
Intercept(4)	0.70	(0.50, 0.92)	1.000	4285.00
Intercept(5)	1.26	(1.01, 1.52)	1.000	2820.00
TruthOld	0.57	(0.32, 0.82)	1.000	3627.00
disc_Intercept	0.00	(0.00, 0.00)
disc_TruthOld	0.02	(-0.20, 0.24)	1.000	2068.00

criteria <- gather_rvars(Bayes_mod, b_Intercept[Response])

signal_dist <- spread_draws(Bayes_mod, b_TruthOld, b_disc_TruthOld) |>
  mutate(b_disc_TruthOld = exp(b_disc_TruthOld)) |>
  group_by(.draw) |>
  reframe(
    x = seq(-3, 3, length = 20),
    d = dnorm(x, mean = b_TruthOld, b_disc_TruthOld)
  ) |>
  ungroup() |>
  curve_interval(.along = x, .width = 0.9)

ggplot() +
  # Noise
  stat_function(aes(linetype = "Noise"), fun = dnorm) +
  # Noise + Signal
  geom_ribbon(aes(x = x, ymin = .lower, ymax = .upper),
              data = signal_dist,
              fill = "grey", alpha = 0.4) +
  geom_line(aes(x, d, linetype = "Noise + Signal"), data = signal_dist) +
  # Thresholds
  stat_slab(aes(xdist = .value, fill = ordered(Response)),
            color = "gray", alpha = 0.6, key_glyph = "polygon",
            data = criteria) +
  # Theme and scales
  scale_fill_brewer("Threshold", type = "div", palette = 2,
                     labels = paste0(1:5, " | ", 2:6),
                     na.translate = FALSE) + 
  labs(color = NULL, linetype = NULL, x = "Obs. signal", y = NULL) +
  theme_classic()

This gives roughly the same results as clm(), but would allow for multilevel modeling of both the location and scale of the latent variable.

Footnotes

Though the CIs are somewhat wider.↩︎
as of 2022-10-06↩︎

ggplot: Easy as pie (charts)

Wed, 11 Aug 2021 21:00:00 GMT

_{This post by no means endorses the use of pie charts. But, if you must, here’s how…}

For some reason, the top Google results for “ggplot2 pie chart” show some very convoluted code to accomplish what should be easy:

Make slices
Add labels to the middle of those slices

Instead, let’s look at the easy way - with position_stack()!

Make some data

We first need some data fit for a pie chart - a column for slice label, and a column for their (preferably relative) size.

d <- data.frame(
  Slices = c("Writing code", "Staring at plot", "Fixing code", "Enjoying plot") |> rep(2),
  Time = c(1, 5, 4, 2, 1, 1, 1, 2),
  When = c("Before reading this post", "After reading this post") |> rep(each = 4)
) |>
  transform(
    # Make time relative
    Time_relative = Time / ave(Time, When, FUN = sum),
    Slices = factor(Slices, levels = unique(Slices)),
    When = factor(When, levels = unique(When))
  )

d

#>            Slices Time                     When Time_relative
#> 1    Writing code    1 Before reading this post    0.08333333
#> 2 Staring at plot    5 Before reading this post    0.41666667
#> 3     Fixing code    4 Before reading this post    0.33333333
#> 4   Enjoying plot    2 Before reading this post    0.16666667
#> 5    Writing code    1  After reading this post    0.20000000
#> 6 Staring at plot    1  After reading this post    0.20000000
#> 7     Fixing code    1  After reading this post    0.20000000
#> 8   Enjoying plot    2  After reading this post    0.40000000

Now let’s build the pie-chart!

library(ggplot2)

ggplot(d, aes(x = 1, y = Time_relative, fill = Slices)) +
  facet_grid(cols = vars(When)) + 
  # Make pie
  coord_polar(theta = "y") +
  # Add the *stacked* columns
  geom_col(position = position_stack(reverse = TRUE), 
           color = "tan3", linewidth = 3, show.legend = FALSE) + 
  # Add labels to the *stacked* position,
  # in the middle of the column (vjust = 0.5)
  geom_text(aes(label = Slices), 
            position = position_stack(vjust = 0.5, reverse = TRUE)) + 
  # Make it a pizza pie!
  see::scale_fill_pizza_d() + 
  theme_void() + 
  labs(title = "Relative time spent building piecharts with ggplot2")

Best served HOT!

ggplot: plot only some of the data

Sun, 11 Jul 2021 21:00:00 GMT

Often (especially when working with large and/or rich datasets) our (gg)plots can feel cluttered with information. But they don’t have to be!

Let’s look at the following plot:

Generate some data

Everything You Always Wanted to Know About ANOVA*

Mon, 24 May 2021 21:00:00 GMT

Analysis of variance (ANOVA) is a statistical procedure, developed by R. A. Fisher, used to analyze the relationship between a continuous outcome (dependent variable) and categorical predictors (independent variables). This procedure produces a linear model, which can be used to estimate the conditional and marginal means of the outcome; In the presence of multiple factorial predictors, the model will include all interaction terms between the factors.

The ANOVA is part of a wider family of statistical procedures that include ANCOVA (which incorporates continuous predictors) and Analysis of Deviance (which allow for non-continuous outcomes¹). This family of procedures all produce an ANOVA table (or ANOVA-like table) which summarizes the relationship between the underlying model and the outcome by partitioning the variation in the outcome into components which can be uniquely attributable to different sources according to the law of total variance. Essentially, each of the model’s terms is represented in a line in the ANOVA table which answers the question how much of the variation in can be attributed to the variation in ??² Where applicable, each source of variance has an accompanying test statistic (often F), sometimes called the omnibus test, which indicates the significance of the variance attributable to that term, often accompanied by some measure of effect size.

In this post I will demonstrate the various types of ANOVA tables, how R does ANOVA (what the defaults are, and how to produce alternatives).

Along the way, I hope to illustrate the applicability of ANOVA tables to other types of models - besides the classical case of a maximal model (all main effects and interactions) with strictly categorical predictors and a continuous outcome.

Here are some assumptions I make about you, the reader, in this post:

You’re familiar with the ideas of multi-factor ANOVAs (what a main effect is, what interactions are…).
You know some R - how to fit a linear model, how to wrangle some data.
~~You are IID and normally distributed.~~

Let’s dive right in!

ANOVAs in R

Toy Data

ggplot: the placing and order of aesthetics matters

Sat, 15 May 2021 21:00:00 GMT

A group of people were asked to what degree they agree or disagree with a statement at two time points.

Agreement <- matrix(c(794, 150, 86,
                       12, 888, 34,
                      570, 333, 23), nrow = 3,
                    dimnames = list(Before = c("Agree", "Meh", "Disagree"), 
                                    After = c("Agree", "Meh", "Disagree")))

Our question is how many people changed their minds. Statistically we might use mcnemar.test() and effectsize::cohens_g(), but we will be focusing on visualization of the data with ggplot2.

We first need to re-structure this matrix into a data frame:

(Agreement_df <- as.data.frame(as.table(Agreement)))

#>     Before    After Freq
#> 1    Agree    Agree  794
#> 2      Meh    Agree  150
#> 3 Disagree    Agree   86
#> 4    Agree      Meh   12
#> 5      Meh      Meh  888
#> 6 Disagree      Meh   34
#> 7    Agree Disagree  570
#> 8      Meh Disagree  333
#> 9 Disagree Disagree   23

The basic plot is:

library(ggplot2)
theme_set(theme_bw())

ggplot(Agreement_df, aes(Before, Freq, fill = After)) + 
  geom_col(
    position = "fill", width = 0.85, 
    color = "black", linewidth = 1
  )

Simple enough.

What we want to do is mark the cells where people did not change their response - where Before is equal to After - with a different line type. We can do this by adding linetype = Before == After into the plots aesthetics. This should give diagonal cells a different line-type compared to the other cells. Simple enough, no?

ggplot(Agreement_df, aes(Before, Freq, fill = After)) + 
  geom_col(
    position = "fill", width = 0.85, 
    color = "black", linewidth = 1,
    mapping = aes(linetype = Before == After) #<<<<<<<<<
  )

What the hell happened?? The order of cells has changed!

Grouping & Order of Mapping

The first thing to understand is that we have some implicit grouping going on.

The group aesthetic is by default set to the interaction of all discrete variables in the plot. […] For most applications the grouping is set implicitly by mapping one or more discrete variables to x, y, colour, fill, alpha, shape, size, and/or linetype.

From the ggplot2 manual on Aesthetics: grouping

This means that our mapping of fill and linetype has been used to set the grouping of the cells.

The second thing to understand is the order in which these grouping aesthetics are used for grouping:

First, the layer-specific aesthetics are used (in our case, linetype = Before == After, which is in the geom_col() layer).
Then (if inherit.aes = TRUE, which is the default) any global aesthetics are used (fill = After, which is set in the call to ggplot()).

This is why the order of the cells has changed: Cells were grouped first by the before-after equality, and only then by the type of “after” response.

The Fix

The fix is easy, we have to make sure the grouping aesthetics are specified in a way that ggplot pulls them in the correct order; that is first by “after” and then by the before-after equality.

Here are all the ways to do that:

Option 1: Be Explicit

We can explicitly set the group aesthetic, using the interaction() function, but to add insult to injury, this function must be supplied with the grouping variables in the reverse order (unless you set lex.order = TRUE):

ggplot(Agreement_df, aes(Before, Freq, fill = After)) + 
  geom_col(
    position = "fill", width = 0.85, 
    color = "black", linewidth = 1,
    mapping = aes(linetype = Before == After,
                  group = interaction(Before == After, After)) #<<<<<<<<<
  )

ggplot(Agreement_df, aes(Before, Freq, fill = After)) + 
  geom_col(
    position = "fill", width = 0.85, 
    color = "black", linewidth = 1,
    mapping = aes(linetype = Before == After,
                  group = interaction(After, Before == After,  #<<<<<<<<<
                                      lex.order = TRUE))       #<<<<<<<<<
  )

Option 2: Set All Grouping Aesthetics Globally / By Layer

We can also keep using the implicit setting for the grouping, but set all of the relevant aesthetics globally:

# Set both in the global aesthetics:
ggplot(Agreement_df, aes(Before, Freq,
                         fill = After, linetype = Before == After)) + 
  geom_col(
    position = "fill", width = 0.85, 
    color = "black", linewidth = 1
  )

Or in the layer itself:

# Set both in the layer aesthetics:
ggplot(Agreement_df, aes(Before, Freq)) + 
  geom_col(
    position = "fill", width = 0.85, 
    color = "black", linewidth = 1,
    mapping = aes(fill = After, linetype = Before == After)
  )

Note then even when setting them globally or in the layer, the order still matters:

ggplot(Agreement_df, aes(Before, Freq)) + 
  geom_col(
    position = "fill", width = 0.85, 
    color = "black", linewidth = 1,
    mapping = aes(linetype = Before == After, fill = After) # Wrong order
  )

Conclusion

The location (global or by layer) and order of aesthetics matters. I didn’t know this, and I felt like I was losing my mind; I hope that by writing this post I will be able to spare you some precious keyboard banging and yelps of sorrow.

Code away!

Testing The Equality of Regression Coefficients

Mon, 15 Feb 2021 22:00:00 GMT

The Problem

You have two predictors in your model. One seems to have a stronger coefficient than the other. But is it significant?

Example: when predicting a worker’s salary, is the standardized coefficient of number of extra hours (xtra_hours) really larger than that of number of compliments given the to boss n_comps?

library(parameters)
library(effectsize)

data("hardlyworking", package = "effectsize")

hardlyworkingZ <- standardize(hardlyworking)

m <- lm(salary ~ xtra_hours + n_comps, data = hardlyworkingZ)

model_parameters(m)

#> Parameter   | Coefficient |   SE |        95% CI |   t(497) |      p
#> --------------------------------------------------------------------
#> (Intercept) |    2.76e-16 | 0.02 | [-0.03, 0.03] | 1.59e-14 | > .999
#> xtra hours  |        0.81 | 0.02 | [ 0.78, 0.84] |    46.60 | < .001
#> n comps     |        0.41 | 0.02 | [ 0.37, 0.44] |    23.51 | < .001

Here are 4 6 methods to test coefficient equality in R.

Note

If we were interested in the unstandardized coefficient, we would not need to first standardize the data.
Note that if one parameter was positive, and the other was negative, one of the terms would need to be first reversed (-X) to make this work.

Method 1: As Model Comparisons

Based on this awesome tweet.

Since:

We can essentially force a constraint on the coefficient to be equal by using a composite variable.

m0 <- lm(salary ~ I(xtra_hours + n_comps), data = hardlyworkingZ)

model_parameters(m0)

#> Parameter            | Coefficient |   SE |        95% CI |   t(498) |      p
#> -----------------------------------------------------------------------------
#> (Intercept)          |    2.80e-16 | 0.02 | [-0.04, 0.04] | 1.31e-14 | > .999
#> xtra hours + n comps |        0.61 | 0.01 | [ 0.58, 0.64] |    41.09 | < .001

We can then compare how this model compares to our first model without this constraint:

anova(m0, m)

#> Analysis of Variance Table
#> 
#> Model 1: salary ~ I(xtra_hours + n_comps)
#> Model 2: salary ~ xtra_hours + n_comps
#>   Res.Df     RSS Df Sum of Sq      F    Pr(>F)    
#> 1    498 113.662                                  
#> 2    497  74.942  1     38.72 256.78 < 2.2e-16 ***
#> ---
#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

We can conclude that the unconstrained model is significantly better than the constrained model - meaning that .

Method 1b: Composite Variable + Difference

Edit (Feb-17, 2021): Thanks to @joejps84 for pointing this out!

We can achieve the same thing in a single model. If we say that the slope of n_comps as equal to the slope of xtra_hours + some change:

So the slope of n_comps in such a model is the difference between the slope of n_comps and xtra_hours:

m1 <- lm(salary ~ I(xtra_hours + n_comps) + n_comps, data = hardlyworkingZ)

model_parameters(m1)

#> Parameter            | Coefficient |   SE |         95% CI |   t(497) |      p
#> ------------------------------------------------------------------------------
#> (Intercept)          |    2.56e-16 | 0.02 | [-0.03,  0.03] | 1.47e-14 | > .999
#> xtra hours + n comps |        0.81 | 0.02 | [ 0.78,  0.84] |    46.60 | < .001
#> n comps              |       -0.40 | 0.03 | [-0.45, -0.35] |   -16.02 | < .001

This give the exact same result ( is the same as the F-value from the anova() test)!

Method 2: Paternoster et al (1998)

According to Paternoster et al. (1998), we can compute a t-test to compare the coefficients:

b <- coef(m)
V <- vcov(m)

tibble::tibble(
  diff_estim = b[2] - b[3],
  diff_SE = sqrt(V[2, 2] + V[3, 3] - 2 * V[2, 3]),
  t_stat = diff_estim / diff_SE,
  df = df.residual(m),
  p_value = 2 * pt(abs(t_stat), df = df, lower.tail = FALSE)
)

#> # A tibble: 1 × 5
#>   diff_estim diff_SE t_stat    df  p_value
#>                  
#> 1      0.402  0.0251   16.0   497 6.83e-47

This gives the exact same results as the first method!

Edit (Feb-17, 2021): As @bmwiernik pointed out, this can also be done with some fancy matrix multiplication:

contr <- c(0, 1, -1)

tibble::tibble(
  diff_estim = b %*% contr,
  diff_SE = sqrt(contr %*% V %*% contr),
  t_stat = diff_estim / diff_SE,
  df = df.residual(m),
  p_value = 2 * pt(abs(t_stat), df = df, lower.tail = FALSE)
)

#> # A tibble: 1 × 5
#>   diff_estim[,1] diff_SE[,1] t_stat[,1]    df p_value[,1]
#>                                 
#> 1          0.402      0.0251       16.0   497    6.83e-47

All of the following solutions are essentially this method, wrapped in some nice functions.

Method 3: `emmeans` <3

We can estimate the slopes from the model using emmeans, and then, with some trickery, compare them!

library(emmeans)

trends <- rbind(
  emtrends(m, ~1, "xtra_hours"),
  emtrends(m, ~1, "n_comps")
)

# clean up so it does not error later
trends@grid$`1` <- c("xtra_hours", "n_comps")
trends@misc$estName <- "trend"

trends

#>  1          trend     SE  df lower.CL upper.CL
#>  xtra_hours 0.811 0.0174 497    0.772    0.850
#>  n_comps    0.409 0.0174 497    0.370    0.448
#> 
#> Confidence level used: 0.95 
#> Conf-level adjustment: bonferroni method for 2 estimates

Compare them:

pairs(trends)

#>  contrast             estimate     SE  df t.ratio p.value
#>  xtra_hours - n_comps    0.402 0.0251 497  16.024  <.0001

Once again - exact same results!

Method 4: `lavaan`

The lavaan package for latent variable analysis and structural equation modeling allows for parameter constraining. So let’s do just that:

library(lavaan)

L <- sem("salary ~ xtra_hours + n_comps", data = hardlyworkingZ)
L0 <- sem("salary ~ a * xtra_hours + a * n_comps", data = hardlyworkingZ)

anova(L0, L)

#> 
#> Chi-Squared Difference Test
#> 
#>    Df    AIC    BIC  Chisq Chisq diff   RMSEA Df diff Pr(>Chisq)    
#> L   0 475.99 488.63   0.00                                          
#> L0  1 682.25 690.68 208.26     208.26 0.64383       1  < 2.2e-16 ***
#> ---
#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

This too yields similar results! (Only slightly different due to different estimation methods.)

We can also directly estimate the difference using lavaan’s “defined parameters” - defines with the := operator:

L <- sem("salary ~ b1 * xtra_hours + b2 * n_comps
         diff := b1 - b2", 
         data = hardlyworkingZ)

parameterEstimates(L, output = "text")[7,]

#> 
#> Defined Parameters:
#>                    Estimate  Std.Err  z-value  P(>|z|) ci.lower ci.upper
#>     diff              0.402    0.025   16.073    0.000    0.353    0.451

Which, again, gives the same results.

Method 5: `car`

Edit (Feb-17, 2021): Thanks to @DouglasKGAraujo for his suggestion!

Even more methods!

library(car)

linearHypothesis(m, c("xtra_hours - n_comps"))

#> Linear hypothesis test
#> 
#> Hypothesis:
#> xtra_hours - n_comps = 0
#> 
#> Model 1: restricted model
#> Model 2: salary ~ xtra_hours + n_comps
#> 
#>   Res.Df     RSS Df Sum of Sq      F    Pr(>F)    
#> 1    498 113.662                                  
#> 2    497  74.942  1     38.72 256.78 < 2.2e-16 ***
#> ---
#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Which once again gives the same result!

Method 6: `multcomp`

Edit (Feb-17, 2021): Thanks to Stefan Th. Gries for his suggestion!

Even more more methods!

library(multcomp)

summary(glht(m, matrix(c(0, 1, -1), nrow = 1)))

#> 
#>   Simultaneous Tests for General Linear Hypotheses
#> 
#> Fit: lm(formula = salary ~ xtra_hours + n_comps, data = hardlyworkingZ)
#> 
#> Linear Hypotheses:
#>        Estimate Std. Error t value Pr(>|t|)    
#> 1 == 0  0.40171    0.02507   16.02   <2e-16 ***
#> ---
#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#> (Adjusted p values reported -- single-step method)

Which once again again gives the same result!

Summary

That’s it really - these 4 6 simple methods have wide applications to GL(M)M’s, SEM, and more.

Enjoy!

(What to do) When Predictors Co-Vary

Mon, 10 Aug 2020 21:00:00 GMT

Co-varying predictors can be a messy business. They make estimates unstable, reducing our statistical power and making interpretation more difficult. In this post I will demonstrate how ignoring the presence of co-variation between predictors when exploring our models can lead to odd results and how we might deal with this issue.

Our Model

For our example, we will use some (fake) developmental-growth data - we have the height and weight of 500 individuals between the ages of 5 and 24. We can plot our tri-variate data like so:

This generally looks as one might expect - taller people weigh more, older people are taller and weigh more as well.

Predicting Weight from Height

Let us fit an OLS linear model¹ to predict weight from height and age:

fit <- lm(weight ~ height + age, data = data)

summary(fit)

#> 
#> Call:
#> lm(formula = weight ~ height + age, data = data)
#> 
#> Residuals:
#>      Min       1Q   Median       3Q      Max 
#> -23.8960  -3.9637  -0.0438   4.3013  25.8607 
#> 
#> Coefficients:
#>              Estimate Std. Error t value Pr(>|t|)    
#> (Intercept) -51.97123    5.27409  -9.854   <2e-16 ***
#> height        0.53458    0.05741   9.312   <2e-16 ***
#> age           2.47319    0.25311   9.771   <2e-16 ***
#> ---
#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#> 
#> Residual standard error: 7.009 on 497 degrees of freedom
#> Multiple R-squared:  0.7856, Adjusted R-squared:  0.7847 
#> F-statistic: 910.4 on 2 and 497 DF,  p-value: < 2.2e-16

Unsurprisingly, both age and height are positively related to weight.

Let’s explore our model - specifically, we want to see what weight can we expect for 3 individuals of the following heights: 120, 145, and 170cm. We can do this with emmeans:

library(emmeans)

em_by_height <- emmeans(fit, ~ height, at = list(height = c(120, 145, 170)))
em_by_height

#>  height emmean    SE  df lower.CL upper.CL
#>     120   49.0 1.536 497     46.0     52.0
#>     145   62.4 0.321 497     61.7     63.0
#>     170   75.7 1.402 497     73.0     78.5
#> 
#> Confidence level used: 0.95

We can also add these expected values to the plot from above:

Something seems off - the expected value for a person 120cm tall seems too high, while the expected value for a person 170cm tall seems too low. Why is that? What’s going on?

First, let’s talk about the elephant in the room - there is obvious multicollinearity between our predictors! If we’re not sure, we can use performance::check_collinearity() to validate this:

performance::check_collinearity(fit)

#> # Check for Multicollinearity
#> 
#> Moderate Correlation
#> 
#>    Term  VIF   VIF 95% CI Increased SE Tolerance Tolerance 95% CI
#>  height 5.26 [4.51, 6.17]         2.29      0.19     [0.16, 0.22]
#>     age 5.26 [4.51, 6.17]         2.29      0.19     [0.16, 0.22]

But how is this related to the funky estimates we got?

Well, this has to do with what we do with the other predictors when exploring a single predictor. In our case, what happens to age when we’re exploring the role of height in our model?

The common and almost default approach is to fix age to a constant. This is really what our model does in the first place: the coefficient of height represents the expected change in weight while age is fixed and not allowed to vary. What constant? A natural candidate (and indeed emmeans’ default) is the mean. In our case, the mean age is 14.9 years. So the expected values produced above are for three 14.9 year olds with different heights. But is this data plausible? If I told you I saw a person who was 120cm tall, would you also assume they were 14.9 years old?

No, you would not. And that is exactly what covariance and multicollinearity mean - that some combinations of predictors are more likely than others.

Predicting Weight from Height (accounting for covariance among predictors)

So how do we get more reasonable expected weights?

Well, we can allow age to vary in our prediction. Vary how? Well, vary with height! So instead of asking “what are the expected heights of 3 individuals that are 120, 145, and 170cm tall, all of the same age”, we can ask “what are the expected heights of 3 individuals that are 120, 145, and 170cm tall, of height-appropriate ages”.

In emmeans this can be done by specifying a predictive formula in cov.reduce. For example:

(rg_multicov <- ref_grid(fit,
                         at = list(height = c(120, 145, 170)),
                         cov.reduce = list(age ~ height))) # This!

#> 'emmGrid' object with variables:
#>     height = 120, 145, 170
#>     age = (predicted by other variables)

rg_multicov@grid

#>   height       age .wgt.
#> 1    120  9.537649     1
#> 2    145 14.640867     1
#> 3    170 19.744085     1

emmeans(rg_multicov, ~ height)

#>  height emmean    SE  df lower.CL upper.CL
#>     120   35.8 0.727 497     34.3     37.2
#>     145   61.8 0.315 497     61.1     62.4
#>     170   87.7 0.673 497     86.4     89.1
#> 
#> Confidence level used: 0.95

We can see from the reference grid (rg_multicov@grid) that age is not fixed, but varies with height.

We can also achieve the same this in a single call to emmeans():

em_by_height2 <- emmeans(fit, ~ height, 
                         at = list(height = c(120,145,170)),
                         cov.red = list(age ~ height))
em_by_height2

#>  height emmean    SE  df lower.CL upper.CL
#>     120   35.8 0.727 497     34.3     37.2
#>     145   61.8 0.315 497     61.1     62.4
#>     170   87.7 0.673 497     86.4     89.1
#> 
#> Confidence level used: 0.95

What we’ve done is essentially re-introducing multicollinearity into our estimates by allowing age to co-vary with height: each expected value is no longer just a function of height, but it is also a function of the expected age for that height².

If we plot these estimates, we get…

…which seems more reasonable.

Summary

Should you do this whenever you have multicollinearity in your data?

No - not always and not only!

You might want to do this whenever exploring one predictor while fixing other to a constant produces uncommon and unlikely combinations of predictors. In fact, such a situation may arise even when measures of multicollinearity (such as the VIF) are not “too” high, as these usually only measure co-linearity, but other patterns of co-variation my be present in your data. In fact this may be useful in any instance of co-variation among predictors, such as suppression / confounding / mediation (take your pick).³

Note also that producing predictions in this manner does not actually “solve” any of the difficulties of interpretations or any of the oddities that arise in statistical suppression / confounding / mediation. (Extra) care should be taken when interpreting the parameters and the predictions of models with co-varying predictors. In this our case, the question of “does weight vary more with age, or with height” can’t cleanly be answered - what is the meaning of looking at the coefficient (or standardized coefficient) of one predictor while holding the other constant when we know they strongly co-vary?

Just the code please:

knitr::opts_chunk$set(echo = FALSE,
                      message = FALSE, 
                      comment = "#>")

library(emmeans)
library(ggplot2)


source('../msbblog_theme_pallets.R')

theme_set(theme_msbblog())

library(dplyr)
library(datawizard)

S <- diag(1,3,3)
S[1,2] <- S[2,1] <- 0.9 # add multicollinearity

set.seed(3)
data <- MASS::mvrnorm(500, rep(0,3), S, empirical = TRUE) %>% 
  data.frame() %>% 
  rename(height = X1,
         age = X2,
         e = X3) %>% 
  mutate(age = change_scale(age, to = c(5, 24)),
         height = change_scale(height, to = c(108, 189)),
         weight = 7 * (scale(height) + scale(age) + scale(age ^ 2 * e)) + 63)


base_plot <- ggplot(data, aes(height, weight, color = age)) +
  geom_point(shape = 16, alpha = 0.5) +
  scale_color_gradientn("Age [yrs]",
                        colours = msbblog_colors[c("blue", "purple", "red", "orange")],
                        values = c(0, 0.6, 1)) +
  labs(y = "Weight [Kg]",
       x = "Height [cm]")

base_plot
fit <- lm(weight ~ height + age, data = data)

summary(fit)
library(emmeans)

em_by_height <- emmeans(fit, ~ height, at = list(height = c(120, 145, 170)))
em_by_height
p_dat <- summary(em_by_height)
p_dat$age <- em_by_height@linfct[,"age"]

base_plot + 
  geom_point(data = p_dat, 
             aes(y = emmean, color = age), 
             shape = 24, size = 2, stroke = 2, fill = "black")
performance::check_collinearity(fit)

(rg_multicov <- ref_grid(fit,
                         at = list(height = c(120, 145, 170)),
                         cov.reduce = list(age ~ height))) # This!
rg_multicov@grid

emmeans(rg_multicov, ~ height)
em_by_height2 <- emmeans(fit, ~ height, 
                         at = list(height = c(120,145,170)),
                         cov.red = list(age ~ height))
em_by_height2
p_dat <- summary(em_by_height2)
p_dat$age <- em_by_height2@linfct[,"age"]

base_plot + 
  geom_point(data = p_dat, 
             aes(y = emmean, color = age), 
             shape = 24, size = 2, stroke = 2, fill = "black")

Footnotes

Ignoring the obvious heteroscedasticity in the data.↩︎
Note that here the expected age is a linear function of height, but this can really take any form: age ~ poly(height,3), age ~ log(height), etc.↩︎
Thus it is also related to the idea of conditioning on a collider, which is really “just” a case of co-varrying predictors with a specific causal structure. Here we are conditioning the association between weight and height on age, which has a similar statistical confounding effect. For more, read this post and comments from 100%CI.↩︎

Estimating and testing GLMs with emmeans

Sun, 12 Apr 2020 21:00:00 GMT

_{This post was written in collaboration with Almog Simchon (@almogsi) and Shachar Hochman (@HochmanShachar). Go follow them.}

The fictional simplicity of Generalized Linear Models

Who doesn’t love GLMs? The ingenious idea of taking a response level variable (e.g. binary or count) and getting some link function magic to treat it as if it was our long-time friend, linear regression.

In the last few days, a preprint by McCabe et al. popped up in our twitter feed (recommended reading!) and re-focused our attention on the problem with interpreting effects and interactions within the GLM framework. McCabe et al. state in the abstract that:

“To date, typical practice in evaluating interaction effects in GLMs extends directly from linear approaches, in which the product term coefficient between variables of interest are used to provide evidence of an interaction effect. However, unlike linear models, interaction effects in GLMs are not equal to product terms between predictor variables and are instead a function of all predictors of a model.”

The what-now?

When fitting a GLM we think of the response level (the binary outcome or the counts that interest us), however, the model is fit (and often all statistical inferences are done) on the latent level - in the realm of the link function.

For interactions (but as you will see soon, not only), it means that when we test the effect of X1 at different levels of X2, we’re testing these effects on the latent (e.g., logistic) level, which might not represent these effects on the response level!

For example, both plots above represent corresponding predictions from the same interaction-model - on the left we have those predictions on the latent level, and on the right these have been transformed back to the response level (the probability). We can see that at the latent level, the effect of X1 on y is very different at all levels of X2, but at the response level these differences can shrink or possibly disappear (e.g., red vs. blue lines), or get larger (red and blue vs. purple line).

This is true regardless of whether or not an interaction was included in the model! And in fact, even main effects on the latent level do not always correspond to the response level the way we would have intuitively imagined.

What follows are 3 methods for testing interactions in GLMs, using emmeans. Again, we highly recommend reading McCabe et al.’s original paper.

Let’s load up some packages:

library(emmeans)  # 1.8.4.1
library(magrittr) # 2.0.3

The Model

The model used here is a logistic regression model, using data adapted from McCabe et al., except we’re using a binomial outcome (see code for data generation at the end of the post):

y <- plogis(xb) < 0.01

model <- glm(y ~ x1 * female + x2,
             data = df,
             family = "binomial")

Using `emmeans` for estimation / testing

If you’re not yet familiar with emmeans, it is a package for estimating, testing, and plotting marginal and conditional means / effects from a variety of linear models, including GLMs.

So let’s answer the question:

Does the effect of sex (female) differ as a function of x1, and how does this interaction differ as a function of x2.

We will use the pick-a-point method for both continuous variables:

For x1: -1, +1
For x2: mean +- sd

1. On the latent level

Predictions from the model on the latent scale.

emmeans(model, ~ x1 + female + x2,
        at = list(x1 = c(-1, 1)),
        cov.reduce = list(x2 = mean_sd)) %>%
  contrast(interaction = c("pairwise", "pairwise"),
           by = "x2")

x2 = -1.020:
 x1_pairwise female_pairwise estimate    SE  df z.ratio p.value
 (-1) - 1    0 - 1              -1.17 0.497 Inf  -2.350  0.0188

x2 = -0.007:
 x1_pairwise female_pairwise estimate    SE  df z.ratio p.value
 (-1) - 1    0 - 1              -1.17 0.497 Inf  -2.350  0.0188

x2 =  1.006:
 x1_pairwise female_pairwise estimate    SE  df z.ratio p.value
 (-1) - 1    0 - 1              -1.17 0.497 Inf  -2.350  0.0188

Results are given on the log odds ratio (not the response) scale.

It seems that on the latent level the (estimated) difference of differences (the interaction) between female and x1 is unaffected by which level of x2 they are conditioned on. This makes sense - we did not model a 3-way interaction, so why should it? Everything is acting as expected.

Or is it? Well, that depends…

2. On the response level (the delta method)

We can also try and answer the same question on the response level using the delta method (baked into emmeans). Here we have two options for defining an “effect”:

An effect is a difference in probabilities.
An effect is a ratio of probabilities.

Predictions from the model on the response scale.

2.1. Differences in probabilities

For this, we just need to add trans = "response" in the call to emmeans():

emmeans(model, ~ x1 + female + x2,
        at = list(x1 = c(-1, 1)),
        cov.reduce = list(x2 = mean_sd),
        trans = "response") %>% 
  contrast(interaction = c("pairwise", "pairwise"),
           by = "x2")

x2 = -1.020:
 x1_pairwise female_pairwise estimate     SE  df z.ratio p.value
 (-1) - 1    0 - 1            -0.0265 0.0787 Inf  -0.336  0.7365

x2 = -0.007:
 x1_pairwise female_pairwise estimate     SE  df z.ratio p.value
 (-1) - 1    0 - 1             0.0976 0.0470 Inf   2.075  0.0380

x2 =  1.006:
 x1_pairwise female_pairwise estimate     SE  df z.ratio p.value
 (-1) - 1    0 - 1             0.0371 0.0163 Inf   2.279  0.0227

# Difference of differences when x2 = -1.02
(0.69457 - 0.44178) - (0.32986 - 0.05059)

[1] -0.02648

It seems that on the response level, we get different results than on the latent level. And not only that, but even though the model did not include a 3-way interaction, the 2-way female:x1 interaction is conditional on the level of x2 - changing in size as a function of x2, and is not significant in low levels of x2!

2.2. Ratios of probabilities

(Also called risk ratios.)

For this, we just need to add trans = "log" and type = "response" in the call to emmeans():

emmeans(model, ~ x1 + female + x2,
        at = list(x1 = c(-1, 1)),
        cov.reduce = list(x2 = mean_sd),
        trans = "log",
        type = "response") %>% 
  contrast(interaction = c("pairwise", "pairwise"), 
           by = "x2")

x2 = -1.02:
 x1_pairwise female_pairwise ratio    SE  df null z.ratio p.value
 (-1) / 1    0 / 1           0.241 0.097 Inf    1  -3.534  0.0004

x2 = -0.007:
 x1_pairwise female_pairwise ratio    SE  df null z.ratio p.value
 (-1) / 1    0 / 1           0.268 0.124 Inf    1  -2.856  0.0043

x2 = 1.006:
 x1_pairwise female_pairwise ratio    SE  df null z.ratio p.value
 (-1) / 1    0 / 1           0.299 0.146 Inf    1  -2.480  0.0131

Tests are performed on the log scale

# Ratio of ratios when x2 = -1.02
(0.69457 / 0.44178) / (0.32986 / 0.05059)

[1] 0.2411265

It seems that even on the response level, different delta methods produce different results!¹ Although we maintain the finding that the size of the 2-way female:x1 interaction is conditional on the level of x2, here it decreases as a function of x2 (but is significant across all (tested) values of x2)!

(Note: as we are interested in the slope of x1, we could have used emtrends instead of emmeans. See code at the end of the post for what that would look like.)

Not just a problem with interactions…

As stated above, this is not only an issue of interactions. For example, when looking at the response level, the effect of x2 is itself conditional on the value of x2!

emmeans(model, ~ x2,
        cov.reduce = list(x2 = mean_sd),
        trans = "response") %>% 
  contrast(method = "consec")

 contrast               estimate      SE  df z.ratio p.value
 (x2-0.007) - (x2-1.02)  -0.2361 0.02190 Inf -10.782  <.0001
 x21.006 - (x2-0.007)    -0.0965 0.00825 Inf -11.695  <.0001

Results are averaged over the levels of: female 
P value adjustment: mvt method for 2 tests

Note how the estimated effect of x2 is smaller for larger values of x2!

Conclusion

The growing popularity of GLMs (and GLMMs) in social research seems to come with another source of researcher degrees of freedom (and we all know how well that works for us)…

What should you do?

Honestly, we don’t know. Some of us feel that since the response variable is our variable of interest, that’s what we should be focusing on; some of us feel that with no common practice, we should stick to the latent level; some of us are agnostic (that covers all of us). We can’t recommend one approach, but we do think that when fitting and working with GLMs, this is a consideration one has to face.² Good luck!

Make the data and model

set.seed(1678)

b0 <- -3.8      # Intercept
b1 <- .35       # X1 Effect
b2 <- .9        # X2 Effect
b3 <- 1.1       # Sex covariate effect
b13 <- .2       # product term coefficient
n <- 1000       # Sample Size
mu <- rep(0, 2) # Specify means

# Specify covariance matrix
S <- matrix(c(1, .5, .5, 1), 
            nrow = 2, ncol = 2) 
sigma <- 1     # Level 1 error

# simulates our continuous predictors from a multivariate 
# normal distribution
rawvars <- MASS::mvrnorm(n = n, mu = mu, Sigma = S) 

cat <- rbinom(n = n, 1, .5)
id <- seq(1:n)
eij <- rep(rnorm(id, 0, sigma))

xb <- (b0) +
  (b1) * (rawvars[, 1]) +
  (b2) * (rawvars[, 2]) + 
  (b3) * cat + 
  b13 * cat * (rawvars[, 1]) + 
  eij

df <- data.frame(x1 = rawvars[, 1],
                 x2 = rawvars[, 2],
                 female = cat)
y <- plogis(xb) < 0.01

model <- glm(y ~ x1 * female + x2,
             data = df,
             family = "binomial")

Using `emtrends`

Note that the inferential results ( and values) are similar (though not identical) to those obtained using emmeans.

# log(odds)
emtrends(model, ~ female + x2, "x1",
         cov.reduce = list(x2 = mean_sd)) %>% 
  contrast(method = "pairwise", by = "x2")

x2 = -1.020:
 contrast          estimate    SE  df z.ratio p.value
 female0 - female1    0.584 0.248 Inf   2.350  0.0188

x2 = -0.007:
 contrast          estimate    SE  df z.ratio p.value
 female0 - female1    0.584 0.248 Inf   2.350  0.0188

x2 =  1.006:
 contrast          estimate    SE  df z.ratio p.value
 female0 - female1    0.584 0.248 Inf   2.350  0.0188

# diffs
emtrends(model, ~ female + x2, "x1",
         cov.reduce = list(x2 = mean_sd),
         trans = "response") %>% 
  contrast(method = "pairwise", by = "x2")

x2 = -1.020:
 contrast          estimate      SE  df z.ratio p.value
 female0 - female1   0.0107 0.04117 Inf   0.259  0.7957

x2 = -0.007:
 contrast          estimate      SE  df z.ratio p.value
 female0 - female1  -0.0542 0.02399 Inf  -2.259  0.0239

x2 =  1.006:
 contrast          estimate      SE  df z.ratio p.value
 female0 - female1  -0.0195 0.00793 Inf  -2.457  0.0140

# ratios
emtrends(model, ~ female + x2, "x1",
         cov.reduce = list(x2 = mean_sd),
         trans = "log", type = "response") %>% 
  contrast(method = "pairwise", by = "x2")

x2 = -1.020:
 contrast          estimate    SE  df z.ratio p.value
 female0 - female1    0.727 0.207 Inf   3.509  0.0004

x2 = -0.007:
 contrast          estimate    SE  df z.ratio p.value
 female0 - female1    0.663 0.233 Inf   2.848  0.0044

x2 =  1.006:
 contrast          estimate    SE  df z.ratio p.value
 female0 - female1    0.605 0.244 Inf   2.476  0.0133

Footnotes

Note that for Poisson models with a “log” link function, this is the same as working on the latent level!↩︎
But hey, whatever you do - don’t model binary / count data with a linear model, okay?↩︎

The Mysterious Case of the Ghost Interaction

Tue, 29 Oct 2019 22:00:00 GMT

_{This spooky post was written in collaboration with Yoav Kessler (@yoav_kessler) and Naama Yavor (@namivor).}.

Experimental psychology is moving away from repeated-measures-ANOVAs, and towards linear mixed models (LMM¹). LMMs have many advantages over rmANOVA, including (but not limited to):

Analysis of single trial data (as opposed to aggregated means per condition).
Specifying more than one random factor (typically crossed random intercepts of subject and item).
The use of continuous variables as predictors.
~~Making you look like you know what you’re doing.~~
~~Defeating the un-dead / reviewer 2.~~
The ability to specify custom models.²

This post will focus on this last point. Specifically, why you should always include main-effects when modeling interactions, and what happens if you don’t (spooky).

Fitting the Right (yet oh so wrong) Model

Say you’ve finally won that grant you submitted to study candy consumption during ghostly themed holidays. As part of your first study, you decide to measure the effects of costume type (scary / cute) and level of neighborhood decor (high / low levels of house decorations) on the total weight of collected candy (in Kg). A simple, yet informative 2-by-2 design.

Being the serious scientist you are, you have several hypotheses:

A main effect for decor level - neighborhoods with more decorations will overall give out more candy.
No main effect for costume - overall, children with cute and scary costumes will receive the same amount of candy (in Kg).
A decor level costume interaction - high decor neighborhoods will favor scary costumes, while low decor neighborhoods will favor cute costumes.

It would only make sense to specify your statistical model accordingly - after all, why shouldn’t your model represent your hypotheses?

In R, such a model is described as candy_kg ~ decor + decor:costume, instructing R to model candy_kg as a function of the effect for decor + the interaction decor:costume.

And so, you fit the model:

options(contrasts = c('contr.sum', 'contr.poly')) # set effects coding (just once)

fit <- aov(candy_kg ~ decor + decor:costume, data = spooky_data)

	Term	df	SS	MS	F	p-value
decor	decor	1	30.00	30.00	23.64	<0.001	0.10
decor:costume	decor:costume	2	120.00	60.00	47.28	<0.001	0.40
Residuals	Residuals	116	147.20	1.27

As predicted, you find both a significant main effect for decor and the interaction decor costume, with the interaction explaining 40% of the variance in collected candy weight. So far so good - your results reflect your hypotheses!

But then you plot your data, and to your horror you find…

It looks like there is no interaction at all! Your interaction was nothing more than a ghost! An apparition! How is this possible?? Where has all of variance explained by it gone???

What IS This??

In fact, had you fit the full model, you would have found:

fit <- aov(candy_kg ~ decor * costume, data = spooky_data)

	Term	df	SS	MS	F	p-value
decor	decor	1	30.00	30.00	23.64	<0.001	0.10
costume	costume	1	120.00	120.00	94.56	<0.001	0.40
decor:costume	decor:costume	1	0.00	0.00	0.00	>0.999	0.00
Residuals	Residuals	116	147.20	1.27

The interaction actually explains 0% of the variance! And the effect of costume is the one that explains 40% of the variance!³ How could this be?? Have we angered Fisher’s spirit somehow?

What happened was that because we did not account for costume in our model, the variance explained by costume was swallowed by the interaction decor costume!

The Math

_{If you find math too scary, feel free to skip to conclusion.}

Travel back to Intro to Stats, and recall that the interaction’s sum-of-squares - - is calculated as:

This is a simplification of the following equation:

Where represents the main effect for and represents the main effect for . We can see that represents the deviation from the additive model - i.e., it is the degree by which the observed cells’ means deviate from what would be expected if there were only the two main effects.

When we exclude the main effect of from out model, we are telling our model that there is no need to estimate the main effect. That is, we set . The resulting is computed not as above, but as:

This formula represents the degree by which the observed cells’ means deviate from what would be expected if there was only the main effect of . But now if the cells’ means deviate in a way that would otherwise have been part of a main effect for , the cells’ deviations from the main effect for will now include the deviations that would otherwise have been accounted for by a main effect of ! This results in the main effect for essentially getting “pooled” into . Furthermore, had you also excluded a main effect for , this effect too would have been “pooled” into the so-called interaction.

In other words:

When we don’t estimate (model) main effects, we change the meaning of interactions - they no longer represents a deviation from the additive model.

Conclusion

Sure, you can specify a model with no main effect and only interactions, but in such a case the interactions no longer mean what we expect them to mean. If we want interactions to represent deviation from the additive model, our model must also include the additive model!

For simplicity’s sake, this example has focused on a simple 2-by-2 between subject design, but the conclusions drawn here are relevant for any design in which a factor interacts with or moderates the effect of another factor or continuous variable.

code for data generation

library(tidyverse)
M <- c(1,2,3,4) + 1 # 4 means with no interaction
n <- 30
e <- scale(rnorm(n),center = TRUE, scale = FALSE) # some error

spooky_data <- expand.grid(decor = c("Low","High"),
                           costume = c("Scary","Cute")) %>%
  mutate(candy_kg = map(M,  ~ .x + e)) %>%
  unnest(cols = candy_kg)

Footnotes

Or hierarchical linear models (HLM)… or mixed linear models (MLM)…↩︎
Whereas in an AVONA analysis with 4 factors you always have: Four main effects + Six 2-way interaction + Four 3-way interaction + One 4-way interaction.↩︎
Note also that the is the same for both models, indicating the same number of parameters overall have been estimated in both. E.g., while in the full model we would have 3 parameters - one for each main effect + one for the interaction, in the misspecified model we have one for the main effect, and two for the interaction. That is, no matter how you tell the model to split the s, the number of parameters needed to model 4 cells will always be 3.↩︎

Accounting for Within- AND Between-Subject Effects

Sun, 20 Oct 2019 21:00:00 GMT

This is a comment on Solomon Kurz’s (@SolomonKurz) recent post¹ where he discusses how group-level data does not always reflect individual-level processes. I highly recommend reading his series of posts on the topic!

In this post I will demonstrate:

How to model both group-level processes and individual-level processes from individual-level data, using linear-mixed models.
When you shouldn’t worry about group-level processes differing from individual-level processes. (controlled experiments for the win!)

Modeling individual- and group-level effects

Let’s work with the now-classic typing speed example. We take a group of 5 typists, and measure the speed of their typing (words per minute), and the rate of typing errors (errors per 100-words). Looking at the data we might get something like this:

`geom_smooth()` using formula = 'y ~ x'
`geom_smooth()` using formula = 'y ~ x'

As we can see, we have two sources of variation that can be used to explain or predict the rate of errors:

Overall, faster typists make less mistakes (group-level pattern).
When typing faster, typists make more mistakes (individual-level pattern).

We can model these using liner mixed models, but first we need to split our predictor (speed) into two variables, each representing a different source of variance - each typist’s average typing speed, and the deviation of each measurement from the typist’s overall mean:²

library(dplyr)
data <- data %>% 
  group_by(ID) %>% 
  mutate(speed_M = mean(speed),
         speed_E = speed - speed_M) %>% 
  ungroup()

head(data)

# A tibble: 6 × 5
     ID  speed errors speed_M speed_E
            
1     1 -0.773 -1.74   -0.188 -0.585 
2     1 -0.144 -0.703  -0.188  0.0438
3     1 -0.686 -1.73   -0.188 -0.498 
4     1  0.560  1.17   -0.188  0.748 
5     1  0.214  0.316  -0.188  0.402 
6     1  0.179  0.392  -0.188  0.367

Let’s fit a liner mixed model and see how we can detect both patterns correctly.

library(lmerTest)

fit <- lmer(errors ~ speed_M + speed_E + (1 + speed_E | ID), 
            data = data)

Your model may suffer from singularity (see see `?lme4::isSingular` and
  `?performance::check_singularity`).
  Some of the standard errors and confidence intervals of the random
  effects parameters are probably not meaningful!

Parameter	Coefficient	SE	CI	CI_low	CI_high	t	df_error	p	Effects	Group
(Intercept)	0.000	0.620	0.95	-1.225	1.225	0.000	143	1.000	fixed
speed_M	-1.600	0.693	0.95	-2.969	-0.231	-2.309	143	0.022	fixed
speed_E	1.400	0.119	0.95	1.165	1.635	11.762	143	0.000	fixed
SD (Intercept)	1.379	0.568	0.95	0.615	3.093	NA	NA	NA	random	ID
SD (speed_E)	0.000	49027.294	0.95	0.000	Inf	NA	NA	NA	random	ID
Cor (Intercept~speed_E)	1.000	297941.433	0.95	NaN	1.000	NA	NA	NA	random	ID
SD (Observations)	0.717	0.043	0.95	0.637	0.806	NA	NA	NA	random	Residual

As we can see, the slope for speed_M is negative (-1.6), reflecting the group-level pattern where typists who are overall faster have fewer errors; whereas the slope for speed_E is positive (1.4), reflecting the individual-level pattern where faster typing leads to more errors.

When are individual-level the same as group-level patterns?

Experiments!
Or to be more precise, when we control the values of the independent variable. Why is this so? Because we control the values of the independent variable, the independent variable cannot be split into different sources of variance: there is either variance between subjects (the variable is manipulated in a between-subjects design) or there is variance within subjects (the variable is manipulated in a within-subjects design), but never both. Thus, although there can be huge heterogeneity in the way subjects present an effect, the average individual-level effect will be the same as the group-level effect (depending on the design).³

Footnotes

and the short twitter discussion that followed.↩︎
Read more in: Hoffman, L. (2015). Time-varying predictors in models of within-person fluctuation. In Longitudinal analysis: Modeling within-person fluctuation and change (pp. 327-392). Routledge.↩︎
Ignoring any differences or artifacts that may arise from the differences in the design itself, such as order effects, etc.↩︎

(Bootstrapping) Follow-Up Contrasts for Within-Subject ANOVAs (part 2)

Tue, 13 Aug 2019 21:00:00 GMT

A while back I wrote a post demonstrating how to bootstrap follow-up contrasts for repeated-measure ANOVAs for cases where you data violates some / any assumptions. Here is a demo of how to conduct the same bootstrap analysis, more simply (no need to make your data wide!)

1. Fit your repeated-measures model with `lmer`

library(lme4)

data(obk.long, package = "afex") # data from the afex package

fit_mixed <- lmer(value ~ treatment * gender * phase * hour + (1|id),
                  data = obk.long)

Note that I assume here data is aggregated (one value per cell/subject), as it would be in a rmANOVA, as so it is sufficient to model only a random intercept.

2. Define the contrast(s) of interest

For this step we will be using emmeans to get the estimates of the pairwise differences between the treatment groups within each phase of the study:

library(emmeans)
# get the correct reference  grid with the correct ultivariate levels!
rg <- ref_grid(fit_mixed, mult.levs = rm_levels)
rg

'emmGrid' object with variables:
    treatment = control, A, B
    gender = F, M
    phase = fup, post, pre
    hour = 1, 2, 3, 4, 5

# get the expected means:
em_ <- emmeans(rg, ~ phase * treatment)

NOTE: Results may be misleading due to involvement in interactions

em_

 phase treatment emmean    SE   df lower.CL upper.CL
 fup   control     4.33 0.603 13.2     3.03     5.64
 post  control     4.08 0.603 13.2     2.78     5.39
 pre   control     4.25 0.603 13.2     2.95     5.55
 fup   A           7.25 0.661 13.2     5.82     8.68
 post  A           6.50 0.661 13.2     5.07     7.93
 pre   A           5.00 0.661 13.2     3.57     6.43
 fup   B           7.29 0.505 13.2     6.20     8.38
 post  B           6.62 0.505 13.2     5.54     7.71
 pre   B           4.17 0.505 13.2     3.08     5.26

Results are averaged over the levels of: gender, hour 
Degrees-of-freedom method: kenward-roger 
Confidence level used: 0.95

# run pairwise tests between the treatment groups within each phase
c_ <- contrast(em_, "pairwise", by = 'phase')
c_

phase = fup:
 contrast    estimate    SE   df t.ratio p.value
 control - A  -2.9167 0.895 13.2  -3.259  0.0157
 control - B  -2.9583 0.787 13.2  -3.760  0.0061
 A - B        -0.0417 0.832 13.2  -0.050  0.9986

phase = post:
 contrast    estimate    SE   df t.ratio p.value
 control - A  -2.4167 0.895 13.2  -2.700  0.0445
 control - B  -2.5417 0.787 13.2  -3.230  0.0166
 A - B        -0.1250 0.832 13.2  -0.150  0.9876

phase = pre:
 contrast    estimate    SE   df t.ratio p.value
 control - A  -0.7500 0.895 13.2  -0.838  0.6869
 control - B   0.0833 0.787 13.2   0.106  0.9938
 A - B         0.8333 0.832 13.2   1.002  0.5885

Results are averaged over the levels of: gender, hour 
Degrees-of-freedom method: kenward-roger 
P value adjustment: tukey method for comparing a family of 3 estimates

# extract the estimates
est_names <- c("fup:  control - A", "fup:  control - B", "fup:  A - B",
               "post: control - A", "post: control - B", "post: A - B",
               "pre:  control - A", "pre:  control - B", "pre:  A - B")
est_values <- summary(c_)$estimate
names(est_values) <- est_names
est_values

fup:  control - A fup:  control - B       fup:  A - B post: control - A 
      -2.91666667       -2.95833333       -0.04166667       -2.41666667 
post: control - B       post: A - B pre:  control - A pre:  control - B 
      -2.54166667       -0.12500000       -0.75000000        0.08333333 
      pre:  A - B 
       0.83333333

3. Run the bootstrap

Now let’s wrap this all in a function that accepts the fitted model as an argument:

treatment_phase_contrasts <- function(mod){
  rg <- ref_grid(mod, mult.levs = rm_levels)
  
  # get the expected means:
  em_ <- emmeans(rg, ~ phase * treatment)
  
  # run pairwise tests between the treatment groups within each phase
  c_ <- contrast(em_, "pairwise", by = 'phase')
  
  # extract the estimates
  est_names <- c("fup:  control - A", "fup:  control - B", "fup:  A - B",
                 "post: control - A", "post: control - B", "post: A - B",
                 "pre:  control - A", "pre:  control - B", "pre:  A - B")
  est_values <- summary(c_)$estimate
  names(est_values) <- est_names
  est_values
}

# test it
treatment_phase_contrasts(fit_mixed)

NOTE: Results may be misleading due to involvement in interactions

fup:  control - A fup:  control - B       fup:  A - B post: control - A 
      -2.91666667       -2.95833333       -0.04166667       -2.41666667 
post: control - B       post: A - B pre:  control - A pre:  control - B 
      -2.54166667       -0.12500000       -0.75000000        0.08333333 
      pre:  A - B 
       0.83333333

Finally, we will use lme4::bootMer to get the bootstrapped estimates!

treatment_phase_results <-
  bootMer(fit_mixed, treatment_phase_contrasts, nsim = 50) # R = 599 at least

NOTE: Results may be misleading due to involvement in interactions

summary(treatment_phase_results) # original vs. bootstrapped estimate (bootMed)


Number of bootstrap replications R = 50 
                   original  bootBias  bootSE   bootMed
fup:  control - A -2.916667  0.017263 0.77841 -2.801902
fup:  control - B -2.958333 -0.017880 0.86119 -3.025705
fup:  A - B       -0.041667 -0.035143 0.98850 -0.066474
post: control - A -2.416667  0.031072 0.82654 -2.383370
post: control - B -2.541667 -0.024860 0.82351 -2.520263
post: A - B       -0.125000 -0.055932 1.03670 -0.216929
pre:  control - A -0.750000 -0.065397 0.73276 -0.851533
pre:  control - B  0.083333  0.024664 0.78592  0.111930
pre:  A - B        0.833333  0.090061 0.95015  0.994195

confint(treatment_phase_results, type = "perc") # does include zero?

                      2.5 %     97.5 %
fup:  control - A -5.062951 -1.2782764
fup:  control - B -4.985715 -1.0325666
fup:  A - B       -2.348035  2.1660820
post: control - A -4.451445 -0.5162071
post: control - B -4.840519 -1.1705024
post: A - B       -2.349137  2.3025369
pre:  control - A -2.427992  0.8830127
pre:  control - B -1.915388  1.7159931
pre:  A - B       -1.530049  2.7527436

Results indicate that the Control group is lower than both treatment groups in the post and fup (follow -up) phases.

If we wanted p-values, we could use this little function (based on this demo):

boot_pvalues <- function(x, side = c(0, -1, 1)) {
  # Based on:
  # https://blogs.sas.com/content/iml/2011/11/02/how-to-compute-p-values-for-a-bootstrap-distribution.html
  side <- side[1]
  x <- as.data.frame(x$t)

  ps <- sapply(x, function(.x) {
    s <- na.omit(.x)
    s0 <- 0
    N <- length(s)

    if (side == 0) {
      min((1 + sum(s >= s0)) / (N + 1),
          (1 + sum(s <= s0)) / (N + 1)) * 2
    } else if (side < 0) {
      (1 + sum(s <= s0)) / (N + 1)
    } else if (side > 0) {
      (1 + sum(s >= s0)) / (N + 1)
    }
  })
  
  setNames(ps,colnames(x))
}

boot_pvalues(treatment_phase_results)

fup:  control - A fup:  control - B       fup:  A - B post: control - A 
       0.03921569        0.03921569        0.94117647        0.03921569 
post: control - B       post: A - B pre:  control - A pre:  control - B 
       0.03921569        0.74509804        0.23529412        0.94117647 
      pre:  A - B 
       0.27450980

These p-values can then be passed to p.adjust() for the p-value adjustment method of your choosing.

Summary

I’ve demonstrated (again!) how to run permutation tests on main effects / interactions, with follow-up analysis using the bootstrap method. Using this code as a basis for any analysis you might have in mind gives you all the flexibility of emmeans, which supports many (many) models!

Signal Detection Theory vs. Logistic Regression

Sun, 28 Jul 2019 21:00:00 GMT

I recently came across a paper that explained the equality between the parameters of signal detection theory (SDT) and the parameters of logistic regression in which the state (“absent”/“present”) is used to predict the response (“yes”/“no”, but also applicable in scale-rating designs) (DeCarlo, 1998).

Here is a short simulation-proof for this equality.

Setup

For this simulations we will need the following packages:

# For plotting
library(ggplot2)

# For extracting SDT parameters
library(neuropsychology)

We will also need to make sure, for the logistic regression analysis, that our factors’ dummy coding is set to effects-coding - otherwise the intercept’s meaning will not correspond to the criterion (aka the overall response bias):

options(contrasts = c('contr.sum', 'contr.poly'))

The Simulations

n <- 100L
B <- 100L

We’ll run 100 simulations with 100 trials each.

Simulation Code

set.seed(1)

SDT_params <- function(state,resp) {
  tab <- table(state,resp)
  
  sdt_res <- dprime(
    n_hit  = tab[2,2],
    n_miss = tab[2,1],
    n_fa   = tab[1,2],
    n_cr   = tab[1,1]
  )
  
  c(sdt_res$dprime , sdt_res$c)
}

logistic_reg_params <- function(state,resp){
  fit <- glm(resp ~ state, family = binomial())
  
  coef(fit)
}

# initialize
res <- data.frame(d_    = numeric(B),
                  c_    = numeric(B),
                  int   = numeric(B),
                  slope = numeric(B))

# Loop
for (b in seq_len(B)) {
  true_sensitivity <- rexp(1,10) # random
  true_criterion <- runif(1,-1,1) # random
  
  # true state vector
  state_i <- rep(c(F,T), each = n/2)
  
  # response vector
  Xn <- rnorm(n/2) # noise dist
  Xs <- rnorm(n/2, mean = true_sensitivity) # signal + noise dist
  X <- c(Xn,Xs)
  resp_i <- X > true_criterion
  
  # SDT params
  res[b,1:2] <- SDT_params(state_i,resp_i)
  
  # logistic regression params
  res[b,3:4] <- logistic_reg_params(state_i,resp_i)
}

Results

SDT parameters are on a standardized normal scale, meaning they are scaled to . However, the logistic distribution’s scale is . Thus, to convert the logistic regression’s parameters to the SDT’s we need to scale both the intercept and the slope by to have them on the same scale as and .¹ Additionally,

The slope must be also scaled by due to R’s default effects coding.
The intercept must also be scaled by - see paper for the full rationale.

The red-dashed line represents the expected regression line predicting the SDT parameters from their logistic counterparts:

(The blue line is the empirical regression line.)

Conclusions

It is also possible to extend this equality to multi-level designs with generalized linear mixed models (GLMM; see chapters 3 and 9 in Modeling Psychophysical Data in R)², but I see no reason this wouldn’t be possible… One could model random effects per subject, and the moderating effect of some on sensitivity could in theory be modeled by including an interaction between and state; similarly, the moderating effect of on the criterion can be modeled by including a main effect for (moderation the intercept).

Footnotes

Note that there is no need for this scaling if the probit link is used instead of the logit function. This demo has focused on the logit link only because it is the more popular option (insert “old man yells at cloud”-gif here).↩︎
Thanks to Kenneth Knoblauch for reaching out!↩︎

(Bootstrapping) Follow-Up Contrasts for Within-Subject ANOVAs

Wed, 08 May 2019 21:00:00 GMT

So you’ve run a repeated-measures ANOVA and found that your residuals are neither normally distributed, nor homogeneous, or that you are in violation of any other assumptions. Naturally you want to run some a-parametric analysis… but how?

In this post I will demonstrate how to run a permutation test ANOVA (easy!) and how to run bootstrap follow-up analysis (a bit more challenging) in a mixed design (both within- and between-subject factors) ANOVA. I’ve chosen to use a mixed design model in this demonstration for two reasons:

I’ve never seen this done before.
You can easily modify this code (change / skip some of these steps) to accommodate purely within- or purely between-subject designs.

Permutation ANOVA

Running a permutation test for your ANOVA in R is as easy as… running an ANOVA in R, but substituting aov with aovperm from the permuco package.

library(permuco)
data(obk.long, package = "afex") # data from the afex package 

# permutation anova
fit_mixed_p <-
  aovperm(value ~ treatment * gender * phase * hour + Error(id / (phase * hour)),
          data = obk.long)

Warning in checkBalancedData(fixed_formula = formula_f, data = cbind(y, : The
data are not balanced, the results may not be exact.

fit_mixed_p

	term	SSn	dfn	SSd	dfd	MSEn	MSEd	F	parametric P(>F)	resampled P(>F)
treatment	treatment	179.73	2	228.06	10	89.87	22.81	3.94	0.055	0.055
gender	gender	83.45	1	228.06	10	83.45	22.81	3.66	0.085	0.082
treatment:gender	treatment:gender	130.24	2	228.06	10	65.12	22.81	2.86	0.104	0.104
phase	phase	129.51	2	80.28	20	64.76	4.01	16.13	<0.001	<0.001
treatment:phase	treatment:phase	77.89	4	80.28	20	19.47	4.01	4.85	0.007	0.009
gender:phase	gender:phase	2.27	2	80.28	20	1.14	4.01	0.28	0.757	0.765
treatment:gender:phase	treatment:gender:phase	10.22	4	80.28	20	2.56	4.01	0.64	0.642	0.641
hour	hour	104.29	4	62.50	40	26.07	1.56	16.69	<0.001	<0.001
treatment:hour	treatment:hour	1.17	8	62.50	40	0.15	1.56	0.09	>0.999	>0.999
gender:hour	gender:hour	2.81	4	62.50	40	0.70	1.56	0.45	0.772	0.772
treatment:gender:hour	treatment:gender:hour	7.76	8	62.50	40	0.97	1.56	0.62	0.755	0.755
phase:hour	phase:hour	11.35	8	96.17	80	1.42	1.20	1.18	0.322	0.319
treatment:phase:hour	treatment:phase:hour	6.64	16	96.17	80	0.42	1.20	0.35	0.990	0.990
gender:phase:hour	gender:phase:hour	8.96	8	96.17	80	1.12	1.20	0.93	0.496	0.498
treatment:gender:phase:hour	treatment:gender:phase:hour	14.15	16	96.17	80	0.88	1.20	0.74	0.750	0.753

The results of the permutation test suggest an interaction between Treatment (a between subject factor) and Phase (a within-subject factor). To fully understand this interaction, we would like to conduct some sort of follow-up analysis (planned comparisons or post hoc tests). Usually I would pass the model to emmeans for any follow-ups, but here, due to our assumption violations, we need some sort of bootstrapping method.

Bootstrapping with `car` and `emmeans`

For bootstrapping we will be using the Boot function from the car package. In the case of within-subject factors, this function requires that they be specified in a multivariate data structure. Let’s see how this is done.

1. Make your data WIIIIIIIIIIDEEEEEEEE

library(dplyr)
library(tidyr)

obk_mixed_wide <- obk.long %>%
  unite("cond", phase, hour) %>%
  spread(cond, value)

head(obk_mixed_wide)

  id treatment gender   age fup_1 fup_2 fup_3 fup_4 fup_5 post_1 post_2 post_3
1  1   control      M -4.75     2     3     2     4     4      3      2      5
2  2   control      M -2.75     4     5     6     4     1      2      2      3
3  3   control      M  1.25     7     6     9     7     6      4      5      7
4  4   control      F  7.25     4     4     5     3     4      2      2      3
5  5   control      F -5.75     4     3     6     4     3      6      7      8
6  6         A      M  7.25     9    10    11     9     6      9      9     10
  post_4 post_5 pre_1 pre_2 pre_3 pre_4 pre_5
1      3      2     1     2     4     2     1
2      5      3     4     4     5     3     4
3      5      4     5     6     5     7     7
4      5      3     5     4     7     5     4
5      6      3     3     4     6     4     3
6      8      9     7     8     7     9     9

This is not enough, as we also need our new columns (representing the different levels of the within subject factors) to be in a matrix column.

obk_mixed_matrixDV <- obk_mixed_wide %>%
  select(id, age, treatment, gender)

obk_mixed_matrixDV$M <- obk_mixed_wide %>%
  select(-id, -age, -treatment, -gender) %>%
  as.matrix()

glimpse(obk_mixed_matrixDV)

Rows: 16
Columns: 5
$ id         1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16
$ age        -4.75, -2.75, 1.25, 7.25, -5.75, 7.25, 8.25, 2.25, 2.25, -7.…
$ treatment  control, control, control, control, control, A, A, A, A, B, …
$ gender     M, M, M, F, F, M, M, F, F, M, M, M, F, F, F, F
$ M

2. Fit your regular model

fit_mixed <- aov(M ~ treatment * gender, obk_mixed_matrixDV)

Note that the left-hand-side of the formula (the M) is a matrix representing all the within-subject factors and their levels, and the right-hand-side of the formula (treatment * gender) includes only the between-subject factors.

3. Define the contrast(s) of interest

For this step we will be using emmeans. But first, we need to create a list of the within-subject factors and their levels (I did say this was difficult - bear with me!). This list needs to correspond to the order of the multi-variate column in our data, such that if there is more than one factor, the combinations of factor levels are used in expand.grid order. In our case:

colnames(obk_mixed_matrixDV$M)

 [1] "fup_1"  "fup_2"  "fup_3"  "fup_4"  "fup_5"  "post_1" "post_2" "post_3"
 [9] "post_4" "post_5" "pre_1"  "pre_2"  "pre_3"  "pre_4"  "pre_5"

rm_levels <- list(hour = c("1", "2", "3", "4", "5"),
                  phase = c("fup", "post", "pre"))

Make sure you get the order of the variables and their levels correct! This will affect your results!

Let’s use emmeans to get the estimates of the pairwise differences between the treatment groups within each phase of the study:

library(emmeans)
# get the correct reference  grid with the correct ultivariate levels!
rg <- ref_grid(fit_mixed, mult.levs = rm_levels)
rg

'emmGrid' object with variables:
    treatment = control, A, B
    gender = F, M
    hour = multivariate response levels: 1, 2, 3, 4, 5
    phase = multivariate response levels: fup, post, pre

# get the expected means:
em_ <- emmeans(rg, ~ phase * treatment)
em_

 phase treatment emmean    SE df lower.CL upper.CL
 fup   control     4.33 0.551 10     3.11     5.56
 post  control     4.08 0.628 10     2.68     5.48
 pre   control     4.25 0.766 10     2.54     5.96
 fup   A           7.25 0.604 10     5.90     8.60
 post  A           6.50 0.688 10     4.97     8.03
 pre   A           5.00 0.839 10     3.13     6.87
 fup   B           7.29 0.461 10     6.26     8.32
 post  B           6.62 0.525 10     5.45     7.80
 pre   B           4.17 0.641 10     2.74     5.59

Results are averaged over the levels of: gender, hour 
Confidence level used: 0.95

# run pairwise tests between the treatment groups within each phase
c_ <- contrast(em_, "pairwise", by = 'phase')
c_

phase = fup:
 contrast    estimate    SE df t.ratio p.value
 control - A  -2.9167 0.818 10  -3.568  0.0129
 control - B  -2.9583 0.719 10  -4.116  0.0054
 A - B        -0.0417 0.760 10  -0.055  0.9983

phase = post:
 contrast    estimate    SE df t.ratio p.value
 control - A  -2.4167 0.931 10  -2.595  0.0634
 control - B  -2.5417 0.819 10  -3.105  0.0275
 A - B        -0.1250 0.865 10  -0.144  0.9886

phase = pre:
 contrast    estimate    SE df t.ratio p.value
 control - A  -0.7500 1.136 10  -0.660  0.7911
 control - B   0.0833 0.999 10   0.083  0.9962
 A - B         0.8333 1.056 10   0.789  0.7177

Results are averaged over the levels of: gender, hour 
P value adjustment: tukey method for comparing a family of 3 estimates

# extract the estimates
est_names <- c("fup:  control - A", "fup:  control - B", "fup:  A - B",
               "post: control - A", "post: control - B", "post: A - B",
               "pre:  control - A", "pre:  control - B", "pre:  A - B")
est_values <- summary(c_)$estimate
names(est_values) <- est_names
est_values

fup:  control - A fup:  control - B       fup:  A - B post: control - A 
      -2.91666667       -2.95833333       -0.04166667       -2.41666667 
post: control - B       post: A - B pre:  control - A pre:  control - B 
      -2.54166667       -0.12500000       -0.75000000        0.08333333 
      pre:  A - B 
       0.83333333

4. Run the bootstrap

Now let’s wrap this all in a function that accepts the fitted model as an argument:

treatment_phase_contrasts <- function(mod){
  rg <- ref_grid(mod, mult.levs = rm_levels)
  
  # get the expected means:
  em_ <- emmeans(rg, ~ phase * treatment)
  
  # run pairwise tests between the treatment groups within each phase
  c_ <- contrast(em_, "pairwise", by = 'phase')
  
  # extract the estimates
  est_names <- c("fup:  control - A", "fup:  control - B", "fup:  A - B",
                 "post: control - A", "post: control - B", "post: A - B",
                 "pre:  control - A", "pre:  control - B", "pre:  A - B")
  est_values <- summary(c_)$estimate
  names(est_values) <- est_names
  est_values
}

# test it
treatment_phase_contrasts(fit_mixed)

fup:  control - A fup:  control - B       fup:  A - B post: control - A 
      -2.91666667       -2.95833333       -0.04166667       -2.41666667 
post: control - B       post: A - B pre:  control - A pre:  control - B 
      -2.54166667       -0.12500000       -0.75000000        0.08333333 
      pre:  A - B 
       0.83333333

Finally, we will use car::Boot to get the bootstrapped estimates!

library(car)
treatment_phase_results <-
  Boot(fit_mixed, treatment_phase_contrasts, R = 50) # R = 599 at least

Loading required namespace: boot

summary(treatment_phase_results) # original vs. bootstrapped estimate (bootMed)


Number of bootstrap replications R = 31 
                   original  bootBias  bootSE     bootMed
fup:  control - A -2.916667  0.044892 0.65137 -2.8333e+00
fup:  control - B -2.958333 -0.026805 0.82950 -3.0000e+00
fup:  A - B       -0.041667 -0.071697 0.40960 -1.6667e-01
post: control - A -2.416667 -0.011444 0.74882 -2.5000e+00
post: control - B -2.541667  0.048310 0.94075 -2.4167e+00
post: A - B       -0.125000  0.059754 0.64484  4.3374e-15
pre:  control - A -0.750000 -0.129339 0.63190 -7.0000e-01
pre:  control - B  0.083333 -0.099923 1.01857  9.1667e-02
pre:  A - B        0.833333  0.029416 0.89102  8.3333e-01

confint(treatment_phase_results, type = "perc") # does include zero?

Bootstrap percent confidence intervals

                       2.5 %     97.5 %
fup:  control - A -4.0000000 -1.8000000
fup:  control - B -4.3571429 -1.4000000
fup:  A - B       -0.8571429  0.7083333
post: control - A -4.0000000 -1.3000000
post: control - B -4.0000000 -0.7500000
post: A - B       -1.3809524  1.0000000
pre:  control - A -2.0000000  0.7500000
pre:  control - B -2.2500000  2.0416667
pre:  A - B       -0.9666667  2.2083333

Results indicate that the Control group is lower than both treatment groups in the post and fup (follow -up) phases.

If we wanted p-values, we could use this little function (based on this demo):

boot_pvalues <- function(x, side = c(0, -1, 1)) {
  # Based on:
  # https://blogs.sas.com/content/iml/2011/11/02/how-to-compute-p-values-for-a-bootstrap-distribution.html
  side <- side[1]
  x <- as.data.frame(x$t)

  ps <- sapply(x, function(.x) {
    s <- na.omit(.x)
    s0 <- 0
    N <- length(s)

    if (side == 0) {
      min((1 + sum(s >= s0)) / (N + 1),
          (1 + sum(s <= s0)) / (N + 1)) * 2
    } else if (side < 0) {
      (1 + sum(s <= s0)) / (N + 1)
    } else if (side > 0) {
      (1 + sum(s >= s0)) / (N + 1)
    }
  })
  
  setNames(ps,colnames(x))
}

boot_pvalues(treatment_phase_results)

fup:  control - A fup:  control - B       fup:  A - B post: control - A 
           0.0625            0.0625            0.6875            0.0625 
post: control - B       post: A - B pre:  control - A pre:  control - B 
           0.0625            0.9375            0.1250            0.9375 
      pre:  A - B 
           0.3750

These p-values can then be passed to p.adjust() for the p-value adjustment method of your choosing.

Summary

I’ve demonstrated how to run permutation tests on main effects / interactions, with follow-up analysis using the bootstrap method. Using this code as a basis for any analysis you might have in mind gives you all the flexibility of emmeans, which supports many (many) models!

Quidditch: Is It All About the Snitch?

Sat, 24 Nov 2018 22:00:00 GMT

Much has been said about how the game of Quidditch is ruined by the scoring system - specifically how it makes no sense that the snitch is worth 150 points and that catching it ends the game (1, 2, 3). Most of these arguments seem to revolve around the claim that it is nearly impossible to win a match of Quidditch without catching the snitch. Is this true? Let’s try and answer this question formally using statistics and R simulations:

What is the probability of winning a Quidditch match without catching the snitch?

Victor Krum caught the snitch for Bulgaria, but Ireland still won (1994 World cup)

The Game, the Rules

Quidditch is a fictional team sport played on broomsticks, devised by author J. K. Rowling, that is played by wizards in the fantasy world of Harry Potter. Like any sport, the game of Quidditch has many rules, but I will summarize here only the ones pertinent to our discussion:

10 points are gained by throwing the Quaffle through one of the opponent team’s three hoops.
150 points are gained by catching the Golden Snitch, which can only be caught by the Seeker.
The game ends when the Golden Snitch is caught.
The winning team is the one has the most points at the end of the game.

Given these rules and game objectives, in order to estimate the probability of winning a match we must first estimate (1) how long does it take a seeker to catch the Snitch on average, which determines how long a game lasts and thus how much time is allotted for the teams to score goals, and (2) what is the rate of goal scoring.

Estimating the Average Game Length

Unfortunately, not many pro-Quidditch matches are described in the books, so this is quite hard to estimate. On the one hand, the only game that is described in its entirety is the 1994 Quidditch World Cup final, and it was extremely short: only 15 minutes or so (4]); On the other hand, the longest game ever lasted 3 months (5]). So the average is somewhere between 15 minutes, and 130,000 minutes… great.

For the sake of our simulations, then, I will assume the average game lasts 90 minutes (assuming Rowling has soccer or rugby in mind). I will also assume that the length of a Quidditch game is exponentially distributed, since the probability of catching the Snitch remains constant (as opposed to it getting easier as the game progresses) - the Snitch’s ability to escape capture does not change (magic) and players are substituted throughout the game, so let’s assume an unchanging level of vigilance.

Together, the distribution of game lengths looks something like this:

This makes the 3 month long game very unlikely ( ), but the 15 minute game rather probable ( ).

Estimating the Rate of Goals Scored

Throughout the books, the final scores of several Quidditch games are mentioned, but since we don’t know their lengths, it is hard to estimate the rate of goals-per-minute (GPM). Going by the 15 minute world cup, in which the final score was 170-160, or 170-10 if only counting goal points, we can see that there were 18 goals in 15 minutes, or an average of 9 goals per 15 minutes per team, or a GPM of 0.6 (or 0.07 for Bulgaria, and 1.13 for Ireland). Though this is only one game, and a very short one at that, these numbers seem close to the averages seen in basketball, where GPM are around 40/48 = 0.83 (6). This is also in line with the game’s depiction in the films as a fast sport, with many goals scored quickly and in succession.

I will also assume that this rate is constant and unchanging throughout the game, regardless of the score (or fatigue of the players, see above), and so will assume GPM has a poisson distribution, with an average of 0.8, making the GPM distribution look something like this:

Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
ℹ Please use `linewidth` instead.

Simulating the Games

(If you’re not that into reading raw code, you can just skip to the conclusions at the end.)

R Setup

set.seed(1994)

sim_quidditch <- function(mean_game_durA, mean_game_durB, GPM_A, GPM_B,
                          snitch_points = 150, goal_points = 10,
                          n_sims = 1e6) {

  # Sim game durations and snitch Points ------------------------------------
  mean_game_dur_rateA <- 1/mean_game_durA
  mean_game_dur_rateB <- 1/mean_game_durB

  game_dursA <- rexp(n_sims, rate = mean_game_dur_rateA)
  game_dursB <- rexp(n_sims, rate = mean_game_dur_rateB)

  # Final game durations
  game_durs <- ifelse(game_dursA < game_dursB, game_dursA, game_dursB)

  # Who got the snitch (and the points)
  got_snitch <- game_dursA < game_dursB
  snitch_pointsA <- got_snitch     * snitch_points
  snitch_pointsB <- (1-got_snitch) * snitch_points



  # Sim goals and goal points -----------------------------------------------
  # Based on the length of the game
  goal_pointsA <- rpois(n_sims,GPM_A*floor(game_durs)) * goal_points
  goal_pointsB <- rpois(n_sims,GPM_B*floor(game_durs)) * goal_points


  # Find Winner -------------------------------------------------------------
  total_pointA <- snitch_pointsA + goal_pointsA
  total_pointB <- snitch_pointsB + goal_pointsB

  who_won <- rep(NA_character_,n_sims)
  who_won[total_pointA > total_pointB] <- 'A'
  who_won[total_pointA < total_pointB] <- 'B'

  list(teamA_points = total_pointA,
       teamB_points = total_pointB,
       Winner = factor(who_won),
       Got_snitch = factor(ifelse(got_snitch,'A','B')))
}

Equal Teams

Let’s start by simulating 1 million games between two teams with equal GPMs and equally good seekers.

res <- sim_quidditch(mean_game_durA = 90,  # in mins
                     mean_game_durB = 90,
                     GPM_A = 0.8,
                     GPM_B = 0.8)
with(res,{
  table(Winner) / 
       length(Winner)
})

Winner
       A        B 
0.497066 0.496060

Under these conditions, the probability of winning a game without catching the snitch is:

with(res, {
  mean(Winner[!is.na(Winner)] != Got_snitch[!is.na(Winner)])
})

[1] 0.03747158

3.75%! Hmm, that does seem quite unfair… Though it does put Fred and George’s gambling odds at around 1:20!

How many games were determined by the snitch - i.e., had the snitch been caught at the same time by the other team, they would have won?

with(res, {
  (
    sum(teamA_points[Winner == 'A'] - 150 < teamB_points[Winner == 'A'] + 150, na.rm = T) +
      sum(teamA_points[Winner == 'B'] + 150 > teamB_points[Winner == 'B'] - 150, na.rm = T)
  ) / 1e6
})

[1] 0.94918

94.9%! Not the best of odds…

Unequal (but matched) Teams

But just like in real sports, different teams have different strengths… Let’s see what happens when we create two teams who have an equal probability of winning, but differ in terms of their seekers and GPMs.

After some trial and error, I found that if we have a team with a seeker who catches the snitch within 67 minutes on average and a GPM of 0.71, versus a team with a seeker who catches the snitch in within 113 minutes on average but with a GPM of 0.90, both teams have a 50% chance of winning.

res <- sim_quidditch(mean_game_durA = 67,  # in mins
                     mean_game_durB = 113,
                     GPM_A = 0.71,
                     GPM_B = 0.90)

with(res,{
  table(Winner)/length(Winner)
})

Winner
       A        B 
0.497701 0.490796

So, what is the chance of winning without catching the snitch?

with(res,{
  mean(Winner[!is.na(Winner)] != Got_snitch[!is.na(Winner)])
})

[1] 0.1213732

12.2%! Still pretty low… very disappointing. Let’s explore each team separately:

with(res,{
  table(Winner, Got_snitch)
})

      Got_snitch
Winner      A      B
     A 497218    483
     B 119494 371302

It seems that 99.9% of team A’s wins were due to their better seeker…

…but that only 24.3% of team B’s wins were achieved by their weaker seeker T!

How many games were determined by the snitch?

with(res, {
  (
    sum(teamA_points[Winner == 'A'] - 150 < teamB_points[Winner == 'A'] + 150, na.rm = T) +
      sum(teamA_points[Winner == 'B'] + 150 > teamB_points[Winner == 'B'] - 150, na.rm = T)
  ) / 1e6
})

[1] 0.901089

90.1%!

Conclusion

If you’ve caught the snitch, you’ve probably won.
If you’ve won, you probably caught the snitch.
If you’ve lost, catching the snitch would have probably changed that.

But… the majority of points are non-snitch related. And it seems to me unlikely that you would have a seeker that was twice as good as the opposing team’s, and so compensating for a weaker seeker seems very likely given this simulation. SO it’s probably best to invest in a better chaser who can bring up your GPM and a better keeper who can lower your opponents’ GPM, than in a seeker who can shave 5 minutes off of his snitch catching time…

Also, maybe someone should change the rules? Perhaps the snitch should only be worth 30 points?

Examining Inter-Rater Reliability in a Reality Baking Show

Wed, 17 Oct 2018 21:00:00 GMT

Game of Chefs is an Israeli reality cooking competition show, where chefs compete for the title of “Israel’s most talented chef”. The show has four stages: blind auditions, training camp, kitchen battles, and finals. Here I will examine the 4th season’s (Game of Chefs: Confectioner) inter-rater reliability in the blind auditions, using some simple R code.

The Format

In the blind auditions, candidates have 90 minutes to prepare a dessert, confection or other baked good, which is then sent to the show’s four judges for a blind taste test. The judges don’t see the candidate, and know nothing about him or her, until after they deliver their decision - A “pass” decision is signified by the judge granting the candidate a kitchen knife; a “fail” decision is signified by the judge not granting a knife. A candidate who receives a knife from at least three of the judges continues on to the next stage, the training camp.

The 4 judges and host, from left to right: Yossi Shitrit, Erez Komarovsky, Miri Bohadana (host), Assaf Granit, and Moshik Roth

Inter-Rater Reliability

I’ve watched all 4 episodes of the blind auditions (for purely academic reasons!), for a total of 31 candidates. For each dish, I recorded each of the four judges’ verdict (fail / pass).

Let’s load the data.¹

df <- read.csv('IJR.csv')
head(df)

  Moshik Assaf Erez Yosi
1      1     1    1    1
2      1     0    0    0
3      1     1    1    0
4      1     0    0    0
5      0     1    1    1
6      1     1    1    1

We will need the following packages:

library(dplyr) # for manipulating the data
library(magrittr) # <3
library(psych) # for computing Choen's Kappa
library(corrr) # for manipulating matricies

We can now use the psych package to compute Cohen’s Kappa coefficient for inter-rater agreement for categorical items, such as the fail/pass categories we have here. ranges from -1 (full disagreement) through 0 (no pattern of agreement) to +1 (full agreement). Normally, is computed between two raters, and for the case of more than two raters, the mean across all pair-wise raters is used.

cohen.kappa(df)


Cohen Kappa (below the diagonal) and Weighted Kappa (above the diagonal) 
For confidence intervals and detail print with all=TRUE
       Moshik Assaf  Erez  Yosi
Moshik   1.00  0.34  0.17  0.29
Assaf    0.34  1.00  0.17  0.68
Erez     0.17  0.17  1.00 -0.16
Yosi     0.29  0.68 -0.16  1.00

Average Cohen kappa for all raters  0.25
Average weighted kappa for all raters  0.25

We can see that overall - surprisingly low for what might be expected from a group of pristine, accomplished, professional chefs and bakers in a blind taste test.

When examining the pair-wise coefficients, we can also see that Erez seems to be in lowest agreement with each of the other judges (and even in a slight disagreement with Yossi!). This might be because Erez is new on the show (this is his first season as judge), but it might also be because of the four judges, he is the only one who is actually a confectioner (the other 3 are restaurant chefs).

For curiosity’s sake, let’s also look at the coefficient between each judge’s rating and the total fail/pass decision, based on whether a dish got a “pass” from at least 3 judges.

df <- df %>% 
  mutate(PASS = as.numeric(rowSums(.) >= 3))
head(df)

  Moshik Assaf Erez Yosi PASS
1      1     1    1    1    1
2      1     0    0    0    0
3      1     1    1    0    1
4      1     0    0    0    0
5      0     1    1    1    1
6      1     1    1    1    1

We can now use the wonderful new corrr package, which is intended for exploring correlations, but can also generally be used to manipulate any symmetric matrix in a tidy-fashion.

cohen.kappa(df)$cohen.kappa %>%
  as_cordf() %>%
  focus(PASS)

# A tibble: 4 × 2
  term    PASS
    
1 Moshik 0.619
2 Assaf  0.746
3 Erez   0.159
4 Yosi   0.676

Perhaps unsurprisingly (to people familiar with previous seasons of the show), it seems that Assaf’s judgment of a dish is a good indicator of whether or not a candidate will continue on to the next stage. Also, once again we see that Erez is barely aligned with the other judges’ total decision.

Conclusion

Every man to his taste…

Even among the experts there is little agreement on what is fine cuisine and what is not worth a doggy bag. Having said that, if you still have your heart set on competing in Game of Chefs, it seems that you should at least appeal to Assaf’s palate.

Bon Appetit!

Footnotes

The data is availabe here↩︎

Common Practice (misuse of) Moderation in Regression

Tue, 11 Sep 2018 21:00:00 GMT

… or how I stopped trusting standardized coefficients.

Say you want to know how perceived importance of job security is related to feelings of job satisfaction. Let’s also say that you suspect that this relationship might differ between Gen-X-ers and millennials with their MTV and their hip-hop. So you conduct a survey, asking 100 Gen-X-ers and 100 millennials to rank how important they think job security is when job searching and their current job satisfaction. You then plug your data into a 2-step hierarchical regression to test the moderating effect of Generation on the effect of Job Security in your favorite stats program (If you’re a Gen-X-er, SPSS. If you’re a millennial, or a reasonable human being, R). You find:

Term	Estimate	SE	t-value	p-value
(Intercept)	4.400	0.393	11.203	<0.001
Group [Millennial]	0.575	0.245	2.343	0.020
Job Security	0.450	0.046	9.717	<0.001

Term	Estimate	SE	t-value	p-value
(Intercept)	3.20	0.527	6.076	<0.001
Group [Millennial]	2.45	0.613	3.994	<0.001
Job Security	0.60	0.064	9.391	<0.001
Group [Millennial] * Job Security	-0.30	0.090	-3.320	0.001

“Very interesting”, you think to yourself. But before drafting your Science submission, you decide to plot your data, just to make sure this trend isn’t somehow driven by outliers, and you find that it is not!

`geom_smooth()` using formula = 'y ~ x'

“This is great!” you confidently think to yourself, “The relationship between the perceived importance of job security and reported job satisfaction is weaker among millennials!”. But how much weaker? You extract the simple slopes for both groups:

Group	Simple Slope	SE	df	t-value	p-value
Gen-X-ers	0.6	0.064	196	9.391	<0.001
Millennials	0.3	0.064	196	4.696	<0.001

A slope of 0.6 for Gen-X-ers and of 0.3 for Millennials. You find it hard to interpret these slopes, so you do the next reasonable thing: you decide to standardize job security importance and job satisfaction.

Just to make sure nothing funny happened, you plot your data again:

`geom_smooth()` using formula = 'y ~ x'

As expected - your data is now scaled and centered! You compute the simple standardized slopes and find that:

Group	Simple Slope	SE	df	t-value	p-value
Gen-X-ers	0.963	0.103	196	9.391	<0.001
Millennials	0.482	0.103	196	4.696	<0.001

“Amazing,” you exclaim to yourself,” the relationship between importance of job security and job satisfaction is nearly perfect among Gen-X-ers, and is half as strong among millennials!” You open MS Word and start typing away…

Something’s not right.

But wait - looking at the plot above, it is clear that the correlation among Gen-X-ers is far from perfect! How is this possible? What’s really going on here?

The short answer is that that the strength of the association (i.e., the correlation) does not equal the strength of the effect (i.e., the slope). Plotting the relationship for each group separately will shed some light on what’s actually going on:

As is now apparent, the strength of the correlation is equal between the groups - if we were to calculate the correlation between within each group, we would find that they are both exactly (in fact, you can see that I made the scatter of points literally identical between the groups), with the only difference between the groups being the difference in scale (and center) of the two variables.¹

Why does this happen?

The slope, even the standardized slope, only measures the expected change in our outcome variable (e.g., Job Satisfaction) as a function of change in a predictor’s values (e.g., Perceived Importance of Job Security). If we’ve standardized our data, the only thing we’ve changed is that the slope now represents the expected change in an outcome’s standardized values as a function of a change in the predictor’s standardized values.

But why does this not yield what we expect? If in a simple regression analysis the standardized slope is the correlation (i.e., the strength of the relationship), why is that not the case here when measuring simple standardized slopes?

The reason is that when we standardize a variable, we standardize it across any other variables that might interact with it, while our question regards the standardized change in as a function of within different levels of a moderator variable.

What can we do?

The first thing we should do is understand what we are estimating and testing when fitting a moderation model: we are testing whether the size of variable ’s effect on variable is different within different levels of some other variable (or, that the slope of is different within different levels of ). Nothing more. Nothing less. In other words, no matter how you slice it, regression can only answer questions regarding the size of an effect (What is the size of the effect? Does this size change under some conditions?). However, if we instead have questions regarding the strength of an association (i.e., the correlation) between X and Y (How strongly are they correlated? Does the correlation change under some conditions?), we are using the wrong tool.

A more appropriate tool for testing if the strength of association changes between levels of an is to use Fisher’s transformation to conduct a simple t-test to compare two correlations (read about the logic behind this transformation here, here, and here). This can be achieved in R using psych::paired.r() … or if you’re a Gen-X-er, I guess you can do this in SAS or SPSS…

P.S.: Above I demonstrated that standardized simple slopes are not the same as “simple” correlations in the context of a moderation model. Similarly, in a multiple regression analysis, standardized coefficients (s) are not semi-partial (part) correlations. If you have questions regarding semi-partial correlations / strength of unique associations, you can:

Convert a standardized coefficient into a semi-partial (part) correlation via (or simply by using ppcor::spcor() in R).
Determine if two unique association differ in strength by way of a dominance analysis (read about it here and here).²

Footnotes

If this sounds like we violated the assumption of homoscedasticity, you’re absolutely right! In a previous post I wrote that we can overcome such a violation with a permutation test. In this case, this would not help, since the problem here is not with the statistical inference, but with the conclusions we draw from the fitted model parameters - we are assigning the wrong meaning to the numbers we observe. We’re using wrong tool for the question we’re asking. This can only be solved by using the right tool.↩︎
In R, lavaan can be used to compare standardized coefficients between groups as well as between predictors using standardizedSolution().↩︎

Stat's What It's All About

Exploring {ggplot2}’s Geoms and Stats

Working with Ordinal Ranks in {marginaleffects}

Fit a model

Class-Wise Predictions

Sum-scores (mean rank)

Contrast the ranks

Average Contrast

POMP

A note for Bayesians

Centering in Moderation Analysis: A Guide

Order Constraints in Bayes Models (with brms)

Ordinal Regression as a Model for Signal Detection

Preface

The Data

Modeling with Classic SDT

Modeling as a Probit Cumulative Ordinal

Unequal Variance

ROC Curve or ROC Curves?

Going Full Bayesian

Footnotes

ggplot: Easy as pie (charts)

Make some data

Now let’s build the pie-chart!

ggplot: plot only some of the data

Everything You Always Wanted to Know About ANOVA*

ANOVAs in R

ggplot: the placing and order of aesthetics matters

Grouping & Order of Mapping

The Fix

Option 1: Be Explicit

Option 2: Set All Grouping Aesthetics Globally / By Layer

Conclusion

Testing The Equality of Regression Coefficients

The Problem

Method 1: As Model Comparisons

Method 1b: Composite Variable + Difference

Method 2: Paternoster et al (1998)

Method 3: emmeans <3

Method 4: lavaan

Method 5: car

Method 6: multcomp

Summary

(What to do) When Predictors Co-Vary

Our Model

Predicting Weight from Height

Predicting Weight from Height (accounting for covariance among predictors)

Summary

Just the code please:

Footnotes

Estimating and testing GLMs with emmeans

The fictional simplicity of Generalized Linear Models

The Model

Using emmeans for estimation / testing

1. On the latent level

2. On the response level (the delta method)

2.1. Differences in probabilities

2.2. Ratios of probabilities

Not just a problem with interactions…

Conclusion

Make the data and model

Using emtrends

Footnotes

The Mysterious Case of the Ghost Interaction

Fitting the Right (yet oh so wrong) Model

The Math

Conclusion

code for data generation

Footnotes

Accounting for Within- AND Between-Subject Effects

Modeling individual- and group-level effects

When are individual-level the same as group-level patterns?

Footnotes

(Bootstrapping) Follow-Up Contrasts for Within-Subject ANOVAs (part 2)

1. Fit your repeated-measures model with lmer

2. Define the contrast(s) of interest

3. Run the bootstrap

Summary

Signal Detection Theory vs. Logistic Regression

Setup

Method 3: `emmeans` <3

Method 4: `lavaan`

Method 5: `car`

Method 6: `multcomp`

Using `emmeans` for estimation / testing

Using `emtrends`

1. Fit your repeated-measures model with `lmer`

Bootstrapping with `car` and `emmeans`