Example: Writing Assessment

Author

David Eubanks

Show the code
library(tidyverse)
library(tapModel)
library(LaplacesDemon) # for mode and rbern
library(knitr)
library(kableExtra)
library(lme4) # for the IRT-style model

data(writing)

student_index <- dasl |> 
                 group_by(occasion_id) |> 
                 summarize(subject_id = first(subject_id)) |> 
                 pull(subject_id)

gpa_std <- dasl |> 
           distinct(subject_id, .keep_all = TRUE) |> 
           arrange(subject_id) |> 
           pull(gpa)

year_index <- dasl |> 
           distinct(occasion_id, .keep_all = TRUE) |> 
           arrange(occasion_id) |> 
           mutate(year = year - 2) |> # map from 2,3,4 to 0,1,2
           pull(year)

1 Example: Writing Assessment

Colleges teach writing, and in the process, evaluate its qualities. This evaluation can become a grade, but there are research uses as well. A written work like an essay is complex, and it’s not obvious that two readers will make the same assessment. Often there’s a scoring guide that associates the perceived characteristics of a piece of writing with a number. For example, “correctness” assesses spelling, grammar, punctuation, and other aspects of standard English, often on a five-point scale. There are several journals devoted to the assessment of writing, and the research community includes writing program administrators, education researchers, linguists, and associated fields. Because of the ratings comparison question, rater agreement statistics are often used, including the kappas, weighted kappas (for ordinal scales), and IRT-type methods.

1.1 Introduction

The data set we’ll examine in this example concerns writing assessments, but it uses a non-standard approach to data generation intended to capture change over time for students. The method internally is called DASL, for Developmental Assessment of Student Learning. College instructors rate students on their writing ability after a semester of observing them, using a 0-4 scale, where zero means “not doing college level work,” and four means “writing at the level of a college graduate.” The scores are assigned holistically, not based on particular written works, unless the instructor chooses to do that. More details are found in the validity study D. Eubanks & Vanovac (2020). The data set considered here is curated from a larger sample to ensure raters and subjects each have a minimal density of ratings.

The ratings are intended to track a student’s progress through a college curriculum over four years, so if their year in school matches the rating, they are “on track.” This gives us a straightforward way to convert the ratings to binary: if the rating is greater than or equal to the year, they are on track and assigned a Class 1 rating. Otherwise they are assigned a zero for that assessment. Because of high admissions standards, virtually every student receives on-track assessments in the first year, so we’ll only consider years 2, 3, and 4.

Show the code
dasl |> 
  group_by(Year = year) |> 
  summarize(Ratings = n(),
            Subjects = n_distinct(subject_id),
            Raters = n_distinct(rater_id),
            `On track` = scales::percent(mean(rating))) |> 
  kable()
Table 1: Rates of on-track assessments by year in college.
Year Ratings Subjects Raters On track
2 1264 505 168 82%
3 2001 710 205 51%
4 1430 510 176 38%

The rates in Table 1 suggest that the standard for success increases over the four years of college as writing assignments become more difficult. This could be seen as a calibration issue with the raters, who may be too lenient with early-career students and too severe raters with college seniors. Or perhaps the degree of challenge ramps up too quickly, and the fourth-year instructors have unrealistic expectations. Those questions are outside the scope of what we can answer with a reliability study. The main idea to take away from Table 1 is that we should anticipate calibration issues.

Because of the repeated-measures of students at different times, there is a new column in the data called occasion_id, which is a combination of subject and year. The writing assessment data is typical in that raters and subjects have varying numbers of ratings associated with them. The original (large) data set was culled to create a reasonable density of connections. Figure 1 is a histogram for raters and subjects, giving the numbers of ratings assigned or received, respectively.

Show the code
raters <- dasl |> count(rater_id) |> mutate(Type = "Raters") |> select(-rater_id)
subjects <- dasl |> count(subject_id) |> mutate(Type = "Subjects") |> select(-subject_id)

rbind(raters, subjects) |> 
  ggplot(aes(x = n)) +
  geom_histogram(color = "white", fill = "steelblue") +
  facet_grid(~Type, scales = "free") +
  theme_bw()
Figure 1: Rating densities for raters and subjects.

Because some of the counts are small, we’ll use partial pooling later to estimate parameters for subjects and raters.

1.2 Modeling Ratings

As a first assessment, we can just ask for the average t-a-p coefficients taken over each year. This ignores the multilevel aspect of occasions being nested into students and time periods.

Show the code
dasl |>
  group_nest(year) |>
  mutate(
    fit = map(
      data,
      ~ .x |>
        as_counts() |>
        fit_counts() |>
        as.list()
    )
  ) |>
  select(-data) |>
  unnest_wider(fit) |> 
  kable(digits = 2)
Table 2: The three-parameter t-a-p model that considers each rating occasion (time + student) as a unique subject. The model is created separately for each year in school.
year t a p ll degenerate
2 0.79 0.36 0.84 0.56 FALSE
3 0.51 0.49 0.51 0.79 FALSE
4 0.38 0.47 0.35 0.76 FALSE

It’s suggestive that \(t \approx p\) in all three years, because that means a subject’s average ratings approximate the probability of Class 1 membership (\(t_i \approx c_i\)). We called such ratings “unbiased” in the development of the t-a-p models, and this condition has a close relationship to the Fleiss Kappa. Another useful connection is that Item Response Theory is a good comparison to make, which I’ll do later on.

The validity study D. Eubanks & Vanovac (2020) showed an interactive relationship between writing scores, time, and grade averages, so this data set is suitable for introducing explanatory variables to the t-a-p rating model. From Chapter 5, the idea is to combine a student’s GPA (gpa) and time in college (year) with the binary “on-track” ratings to combine the explanatory power of a student ability model with the ratings assessments in one model. In this example, we’ll use first year college grade point averages (GPAs), since we’re only considering ratings after the first year. College grades are assigned by the same people who are assigning the writing ratings, so it would be complicated to use cumulative GPAs, as this would likely violate an independence assumption.

If the ratings were unbiased, we can use a logistic regression to get a sense of how the student ability model might fit the data, using average ratings as a proxy for the occasion-level \(t_i\) coefficients. This assumes that individual ratings by rater \(j\) on occasion \(m\) (a student at a given time) are weighted coin flips (Bernoulli trials)

\[ R_{mj} \sim \operatorname{Bernoulli}(\pi_{mj}), \]

where the frequency of Class 1 ratings (on-track student) \(\pi_{im}\) is modeled by that student’s first year GPA and time in college via

\[ \begin{aligned} \operatorname{logit}(\pi_{mj}) &= \alpha_0 + \alpha_{\mathrm{gpa}} G_i + \alpha_{\mathrm{gpa2}} G_i^2 \\ &- \delta_{\mathrm{year3}} \mathbb{I}(Y_m=3) - \delta_{\mathrm{year4}} \mathbb{I}(Y_m=4) \\ &+ \gamma_{\mathrm{year3}} G_i \mathbb{I}(Y_m=3) + \gamma_{\mathrm{year4}} G_i \mathbb{I}(Y_m=4). \end{aligned} \]

Here, the \(\alpha\) coefficients in the first line represent the assumed-static academic ability of a student, proxied by first year GPA (\(G_i\)). Besides the validity study mentioned earlier, there is solid support in the literature for the reliability of GPA and its usefulness as an indicator of general academic ability, which we can think of as a combination of academic preparation, general intelligence, study skills, personality, and attitude toward learning. See D. A. Eubanks et al. (2020) for more. The quadratic term \(G_i^2\) is suggested by the validity study. This is a typical construction with grade averages; we often need that quadratic term (or splines) to get the residuals approximately flat.

The \(\delta\) coefficients represent the difficulty ramp we saw in the raw averages in Table 1. It would be simpler to assume a linear progression, but some testing showed that this is a bad assumption, so the year is turned into an indicator variable instead. The \(\gamma\) coefficients allow for interaction between ability and time, the necessity of which was the main finding in the validity study of the DASL data, concluding that there’s a Matthew Effect.

Show the code
breaks <- seq(0, 1, by = .1)

gpa_model <- glm(rating ~ year * gpa + I(gpa^2), 
                 dasl |> mutate(year = as.factor(year)), 
                 family = "binomial")

auc <- tapModel::compute_auc(m = gpa_model)

#summary(gpa_model)

dasl$glm <- fitted.values(gpa_model)

dasl |> 
  mutate(
    bin = cut(glm, breaks = breaks, include.lowest = TRUE)
  ) |>
group_by(bin, year) |> 
  summarise(
    pred = mean(glm),
    obs  = mean(rating),
    n = n()
  ) |> 
  ggplot(aes(x = pred, y = obs)) +
  geom_abline(
    intercept = 0,
    slope = 1,
    linetype = "dashed"
  ) +
  geom_point(aes(size = n),alpha = .2) +
  geom_line() +
  coord_equal(xlim = c(0, 1), ylim = c(0, 1)) +
  theme_bw() +
  facet_grid(~year) +
  xlab("Modeled Pr[rating = 1]") +
  ylab("Avg Rating") +
  scale_x_continuous(labels = seq(0,1,.25))
Figure 2: Rating calibration by year for a logistic model that allows GPA and year to interact.

The model fits well enough with AUC = 0.77, and all but one of the coefficients (year3:gpa) is convincingly non-zero. I’m more interested in the rating calibration than the model coefficients. It is shown in Figure 2, and we’ll compare it to the multi-level model computed with MCMC below.

The logistic model is similar to an IRT model, just lacking coefficients for raters and students. If \(t \approx p\) holds for the multilevel rater model, it will be useful to compare IRT coefficients to the t-a-p coefficients, since a student-level bias in on-track ratings is similar to \(t_i\) in that case.

1.3 A Bayesian MCMC Model

In the simplest t-a-p models, we assume a latent true classification for each subject, where \(t\) is the (constant) prevalence rate of Class 1, and each subject \(j\) has a true class distributed via

\[ T_j \sim \operatorname{Bernoulli}(t). \]

Per the discussion in Chapter 5, we can add structure to the latent class distribution parallel to the logistic model above. We allow \(T_i\) to depend combination of a latent writing ability and the difficulty of the task, e.g.

\[ \begin{aligned} t_m &= \Pr(T_m = 1) \sim \text{Bernoulli} (\text{logit}^{-1}( \theta_{iY})) \text{, where}\\ \\ \theta_{iY} &= \underbrace{ \alpha_0 + \alpha_{\mathrm{gpa}} G_i + \alpha_{\mathrm{gpa2}} G_i^2 }_{\text{general academic ability}} \\ &- \underbrace{ \delta_{\mathrm{year3}} \mathbb{I}(Y_m=3) - \delta_{\mathrm{year4}} \mathbb{I}(Y_m=4) }_{\text{difficulty ramp}} \\ &+ \underbrace{\gamma_{\mathrm{year3}} G_i \mathbb{I}(Y_m=3) + \gamma_{\mathrm{year4}} G_i \mathbb{I}(Y_m=4)}_{\text{interaction}}. \end{aligned} \]

The subscripts are complicated because each occasion \(m\) is a combination of a student \(i\) and year \(Y\). This is just the logistic model seen earlier, but now being used to model the latent class probability. Together with the rest of the t-a-p model, this specifies a model we might call X-t-a-p, where X comprises explanatory variables in a regression model for a subject \(i\)’s class probability \(t_i\). That addition introduces a new step in the generative process for producing ratings.

As noted earlier, to accommodate the small sample sizes at the left end of the Figure 1 histograms, we’ll partially pool the rater parameters \(a_i\) and \(p_i\), with

\[ a_i = \text{logit}^{-1}(\mu_a +z_i\sigma_{a}), \]

and put priors on these new parameters. In this formulation, rater accuracy is pooled by using a common mean (on the logit scale) with an offset \(z_i\) determining rater \(i\)s accuracy. This explicit mean and offset is used instead of using a prior like \(N(\mu_a,\sigma_a)\) to avoid convergence problems in the MCMC geometry (see Neal’s Funnel for more). The initial model specification for \(p_i\) was analogous, but the rater calibration (increasing difficulty) noted above ultimately required the addition of intercepts for years 3 and 4 so that these random-assignment rates could reflect the rating styles within each year.

1.4 Prior Predictive Check

Following recommendations from Gelman et al. (2026), we’ll simulate ratings from the proposed model to assess its plausibility. Before fitting the model with the ratings data, we simulate ratings from the prior distributions alone, as they get filtered through the model assumptions, to check the match with real data. The work is done with a Stan script, which is logically organized in blocks to describe data inputs, parameters to be estimated, prior distributions, and additional quantities to generate for diagnostic purposes. This script omits the influence of ratings, so that it only has prior distributions and our model assumptions for the latent class based on GPA and year in school, which are necessaary to construct the prior \(t_m\) and hence simulate ratings.

View Stan code
data {
  int<lower=1> N;
  int<lower=1> I;
  int<lower=1> M;
  int<lower=1> R;

  array[N] int<lower=1, upper=M> occasion_index;
  array[N] int<lower=1, upper=R> rater_index;

  array[M] int<lower=1, upper=I> student_index;

  vector[I] gpa_std;
  
  // occasion-level difficulty variable
  array[M] int<lower=0, upper=2> year_index;
}

parameters {
  // --------------------------------
  // // Student writing ability predicted from first-year GPA
  // --------------------------------

  real alpha_0;
  real alpha_gpa;
  real alpha_gpa2; // squared term

  // --------------------------------
  // Writing difficulty over time
  // --------------------------------

  real delta_year3;
  real delta_year4;
  
  // interaction with GPA per validity study
  real gamma_year3; 
  real gamma_year4;

  // --------------------------------
  // Rater accuracy hierarchy
  // --------------------------------

  real mu_a;
  real<lower=0> sigma_a;
  vector[R] z_a;

  // --------------------------------
  // Rater random/default assignment
  // --------------------------------

  real mu_p;
  real<lower=0> sigma_p;
  vector[R] z_p;
  real delta_p3; // year 3 rate adjustment
  real delta_p4; // year 4 rate adjustment
}

transformed parameters {
  // Student writing ability predicted from first-year GPA
  vector[I] ability;

  // occasion-specific writing difficulty
  vector[M] difficulty;

  // ability relative to difficulty
  vector[M] eta_t;

  // prior probability of true Class 1
  vector<lower=0, upper=1>[M] t;

  // partially pooled rater accuracy
  vector<lower=0, upper=1>[R] a;

  // year-specific partially pooled random/default assignment rate
  matrix<lower=0, upper=1>[R, 3] p;

  // --------------------------------
  // Ability and difficulty model
  // --------------------------------

  ability =
    alpha_0 +
    alpha_gpa * gpa_std +
    alpha_gpa2 * square(gpa_std);

   for (m in 1:M) {
    int i = student_index[m];
  
    if (year_index[m] == 0) {
      difficulty[m] = 0;
  
      eta_t[m] =
        ability[i];
  
    } else if (year_index[m] == 1) {
      difficulty[m] = delta_year3;
  
      eta_t[m] =
        ability[i]
        - difficulty[m]
        + gamma_year3 * gpa_std[i];
  
    } else {
      difficulty[m] = delta_year4;
  
      eta_t[m] =
        ability[i]
        - difficulty[m]
        + gamma_year4 * gpa_std[i];
    }
  }

  t = inv_logit(eta_t);

  // partially pooled rater accuracy
  a = inv_logit(mu_a + sigma_a * z_a);

  // partially pooled rater randomness by year and rater
  for (j in 1:R) {
    real eta_p = mu_p + sigma_p * z_p[j];

    p[j, 1] = inv_logit(eta_p); // year 2
    p[j, 2] = inv_logit(eta_p + delta_p3); // year 3
    p[j, 3] = inv_logit(eta_p + delta_p4); // year 4
  }
}

model {
  // --------------------------------
  // Priors: student ability
  // --------------------------------

  alpha_0 ~ normal(0, 2);
  alpha_gpa ~ normal(0, 1);
  alpha_gpa2 ~ normal(0, 1);

  // --------------------------------
  // Prior: writing difficulty
  // --------------------------------

  delta_year3 ~ normal(0, 2);
  delta_year4 ~ normal(0, 2);
  gamma_year3 ~ normal(0, 1);
  gamma_year4 ~ normal(0, 1);

  // --------------------------------
  // Priors: rater parameters
  // --------------------------------

  mu_a ~ normal(0, .75); // a_pop presumed to be in about .23 to .77
  sigma_a ~ normal(0, 1);
  z_a ~ std_normal();

  mu_p ~ normal(0, .75); 
  sigma_p ~ normal(0, 1);
  z_p ~ std_normal();
  delta_p3 ~ normal(0, 0.75);
  delta_p4 ~ normal(0, 0.75);
}

generated quantities {
  array[M] int<lower=0, upper=1> T_rep;
  array[N] int<lower=0, upper=1> rating_rep;

  for (m in 1:M) {
    T_rep[m] = bernoulli_rng(t[m]);
  }

  for (n in 1:N) {
    int m = occasion_index[n];
    int j = rater_index[n];
    int y = year_index[m] + 1;
    real pj = p[j, y];
    real pr1;

    if (T_rep[m] == 1) {
      pr1 = a[j] + (1 - a[j]) * pj;
    } else {
      pr1 = (1 - a[j]) * pj;
    }

    rating_rep[n] = bernoulli_rng(pr1);
  }
}

The priors for class probabilities are shown in Figure 3.

Show the code
if(0){
  stan_file <- "code/Example_writing_ppc2.stan"

  compiled_model <- cmdstanr::cmdstan_model(stan_file)
  
  stan_data <- list(
    N = nrow(dasl),
    I = n_distinct(dasl$subject_id), 
    R = n_distinct(dasl$rater_id),
    M = n_distinct(dasl$occasion_id),
    gpa_std = gpa_std,
    year_index = year_index,
   # rating = dasl$rating,
    student_index = student_index, # see above
    rater_index = dasl$rater_id,
    occasion_index = dasl$occasion_id)
  
  fit_prior <- compiled_model$sample(
    data = stan_data,
  #  init = init_values,
    seed = 123,
    chains = 4,
    parallel_chains = 4,
    iter_warmup = 1000,
    iter_sampling = 1000,
    adapt_delta = 0.95,
    max_treedepth = 12,
    refresh = 1000)
  
  #shinystan::launch_shinystan(fitted_model)
  #fitted_model$diagnostic_summary()
  
 draws <- fit_prior$draws(
  variables = c("a", "p", "t", "rating_rep"),
  format = "draws_df"
  )

  write_rds(draws, "data/Example_writing_ppc.rds")

} else {
  draws <- read_rds("data/Example_writing_ppc.rds")
}

t_prior <- draws |>
  posterior::as_draws_df() |>
  dplyr::select(.draw, starts_with("t[")) |>
  tidyr::pivot_longer(
    -.draw,
    names_to = "occasion",
    values_to = "value"
  ) |> 
  mutate(occasion_id = as.integer(str_extract(occasion, "\\d+"))
  )

t_prior |> 
  left_join(
    dasl |>
      select(occasion_id, year)
  ) |>
  ggplot(aes(x = value)) +
  geom_histogram(bins = 50, color = "white", fill = "steelblue") +
#  geom_vline(aes(xintercept = value), data = empirical_ratings, color = "red") +
  facet_wrap(~year) +
  theme_bw()
Figure 3: Prior predictive check of the probability t_m that a rating occassion m’s latent class is 1, showing the distributions for each year over many draws.

The bathtubby prior distributions in Figure 3 are not plausible, a consequence of too-loose priors on the latent scale that spread out the distribution so that when we transform it with inverse logit, most of the mass is in the tails. This shows the utility of a prior predictive check, and I’ll change those latent scale priors in the Stan script to a more restrictive

model {
  // partial specification to show the changes
  alpha_0      ~ normal(0, 1.0);
  alpha_gpa    ~ normal(0, 0.5);
  alpha_gpa2   ~ normal(0, 0.5);
  delta_year3  ~ normal(0, 0.5);
  delta_year4  ~ normal(0, 0.5);
  gamma_year3  ~ normal(0, 0.5);
  gamma_year4  ~ normal(0, 0.5);
}

That results in the new prior-predictive distributions found in Figure 4.

Show the code
if(0){
  stan_file <- "code/Example_writing_ppc3.stan"

  compiled_model <- cmdstanr::cmdstan_model(stan_file)
  
  stan_data <- list(
    N = nrow(dasl),
    I = n_distinct(dasl$subject_id), 
    R = n_distinct(dasl$rater_id),
    M = n_distinct(dasl$occasion_id),
    gpa_std = gpa_std,
    year_index = year_index,
   # rating = dasl$rating,
    student_index = student_index, # see above
    rater_index = dasl$rater_id,
    occasion_index = dasl$occasion_id)
  
  fit_prior <- compiled_model$sample(
    data = stan_data,
  #  init = init_values,
    seed = 123,
    chains = 4,
    parallel_chains = 4,
    iter_warmup = 1000,
    iter_sampling = 1000,
    adapt_delta = 0.95,
    max_treedepth = 12,
    refresh = 1000)
  
  #shinystan::launch_shinystan(fitted_model)
  #fitted_model$diagnostic_summary()
  
 draws <- fit_prior$draws(
  variables = c("a", "p", "t", "rating_rep"),
  format = "draws_df"
  )

 write_rds(draws, "data/Example_writing_ppc2.rds")

} else {
  draws <- read_rds("data/Example_writing_ppc2.rds")
}

t_prior <- draws |>
  posterior::as_draws_df() |>
  dplyr::select(.draw, starts_with("t[")) |>
  tidyr::pivot_longer(
    -.draw,
    names_to = "occasion",
    values_to = "value"
  ) |> 
  mutate(occasion_id = as.integer(str_extract(occasion, "\\d+"))
  )

t_prior |> 
  left_join(
    dasl |>
      select(occasion_id, year)
  ) |>
  ggplot(aes(x = value)) +
  geom_histogram(bins = 50, color = "white", fill = "steelblue") +
#  geom_vline(aes(xintercept = value), data = empirical_ratings, color = "red") +
  facet_wrap(~year) +
  theme_bw()
Figure 4: Prior predictive check of t_m by year after making priors more informative.

The distributions in Figure 4 are more reasonable. Similar plots for \(a_j\) and \(p_j\) are also acceptable. Next we’ll check the simulated ratings from the \(t_m\) model parameters in conjunction with the prior-derived \(a_j\) and \(p_j\).

Show the code
rating_prior <- draws |>
  posterior::as_draws_df() |>
  dplyr::select(.draw, matches("^rating_rep\\[")) |>
  tidyr::pivot_longer(
    -.draw,
    names_to = "row",
    values_to = "rating"
  ) |>
  mutate(
    row_id = as.integer(str_extract(row, "\\d+"))
  )

empirical_ratings <- dasl |> group_by(year) |> summarize(rating_mean = mean(rating))

rating_prior |>
  left_join(
    dasl |>
      mutate(row_id = row_number()) |>
      select(row_id, year),
    by = "row_id"
  ) |>
  summarise(
    mean_rating = mean(rating),
    .by = c(.draw, year)
  ) |>
  ggplot(aes(mean_rating)) +
  geom_histogram(bins = 50, color = "white", fill = "steelblue") +
  geom_vline(aes(xintercept = rating_mean), data = empirical_ratings, color = "red") +
  facet_wrap(~year) +
  theme_bw()
Figure 5: Prior predictive check of ratings by year, showing the distributions over many draws. The vertical lines are the actual rating averages.

Figure 5 shows the distribution of the mean simulated rating in each year, with the observed mean shown in red. The priors, which you can see in the Stan script, allow a wide range of possible outcomes and assign reasonable probability to outcomes resembling the observed data. They do not strongly predetermine the observed pattern of ratings. The ratings average in year two is “surprising” to the model, and we’ll see that this is related to rater biases to be more lenient in that time period.

The priors now seem reasonable, so we’ll proceed with parameter estiation that combines that prior model with the multilevel t-a-p model.

1.5 Parameter Estimation

The full Stan script includes the likelihood calculation from the binomial mixture, combining the prior model for \(t_i\) based on grades and timing with the ratings and rater parameters.

View Stan code
// Longitudinal t-a-p model for "on-track" writing proficiency
//
// Student latent writing ability estimated from first year college gpa
//   ability_i = alpha_0
//             + alpha_gpa * gpa_i
//
// Writing difficulty at occasion m:
//   difficulty_m = delta_year * year_index[m]
//
// Probability of being truly "on track":
//   logit(t_m) = ability_i - difficulty_m
//
// where m indexes student-timepoint occasions and i indexes students.
//
// Binary latent proficiency:
//   T_m ~ Bernoulli(t_m)
//
// Rater accuracy:
//   logit(a_j) = mu_a + sigma_a * z_a[j]
//
// Rater random/default Class-1 assignment:
//   logit(p_j) = mu_p + sigma_p * z_p[j]
//
// Ratings are conditionally independent given T_m, a_j, and p_j.
// The discrete T_m are marginalized at the student-timepoint level.

data {
  int<lower=1> N;   // total number of ratings
  int<lower=1> I;   // number of unique students
  int<lower=1> M;   // number of student-timepoint occasions
  int<lower=1> R;   // number of raters

  // rating-level data
  array[N] int<lower=0, upper=1> rating;
  array[N] int<lower=1, upper=M> occasion_index;
  array[N] int<lower=1, upper=R> rater_index;

  // occasion -> student mapping
  array[M] int<lower=1, upper=I> student_index;

  // student-level explanatory variable
  vector[I] gpa_std;

  // occasion-level difficulty variable
  array[M] int<lower=0, upper=2> year_index;
}

parameters {
  // --------------------------------
  // // Student writing ability predicted from first-year GPA
  // --------------------------------

  real alpha_0;
  real alpha_gpa;
  real alpha_gpa2; // squared term

  // --------------------------------
  // Writing difficulty over time
  // --------------------------------

  real delta_year3;
  real delta_year4;
  
  // interaction with GPA per validity study
  real gamma_year3; 
  real gamma_year4;

  // --------------------------------
  // Rater accuracy hierarchy
  // --------------------------------

  real mu_a;
  real<lower=0> sigma_a;
  vector[R] z_a;

  // --------------------------------
  // Rater random/default assignment
  // --------------------------------

  real mu_p;
  real<lower=0> sigma_p;
  vector[R] z_p;
  real delta_p3; // year 3 rate adjustment
  real delta_p4; // year 4 rate adjustment
}

transformed parameters {
  // Student writing ability predicted from first-year GPA
  vector[I] ability;

  // occasion-specific writing difficulty
  vector[M] difficulty;

  // ability relative to difficulty
  vector[M] eta_t;

  // prior probability of true Class 1
  vector<lower=0, upper=1>[M] t;

  // partially pooled rater accuracy
  vector<lower=0, upper=1>[R] a;

  // year-specific partially pooled random/default assignment rate
  matrix<lower=0, upper=1>[R, 3] p;

  // --------------------------------
  // Ability and difficulty model
  // --------------------------------

  ability =
    alpha_0 +
    alpha_gpa * gpa_std +
    alpha_gpa2 * square(gpa_std);

   for (m in 1:M) {
    int i = student_index[m];
  
    if (year_index[m] == 0) {
      difficulty[m] = 0;
  
      eta_t[m] =
        ability[i];
  
    } else if (year_index[m] == 1) {
      difficulty[m] = delta_year3;
  
      eta_t[m] =
        ability[i]
        - difficulty[m]
        + gamma_year3 * gpa_std[i];
  
    } else {
      difficulty[m] = delta_year4;
  
      eta_t[m] =
        ability[i]
        - difficulty[m]
        + gamma_year4 * gpa_std[i];
    }
  }

  t = inv_logit(eta_t);

  // partially pooled rater accuracy
  a = inv_logit(mu_a + sigma_a * z_a);

  // partially pooled rater randomness by year and rater
  for (j in 1:R) {
    real eta_p = mu_p + sigma_p * z_p[j];

    p[j, 1] = inv_logit(eta_p); // year 2
    p[j, 2] = inv_logit(eta_p + delta_p3); // year 3
    p[j, 3] = inv_logit(eta_p + delta_p4); // year 4
  }
}

model {
  vector[M] log_L0 = rep_vector(0.0, M);
  vector[M] log_L1 = rep_vector(0.0, M);

  // --------------------------------
  // Priors: student ability
  // --------------------------------

  alpha_0 ~ normal(0, 1.0);
  alpha_gpa ~ normal(0, 0.5);
  alpha_gpa2 ~ normal(0, 0.5);

  // --------------------------------
  // Prior: writing difficulty
  // --------------------------------

  delta_year3 ~ normal(0, 0.5);
  delta_year4 ~ normal(0, 0.5);
  gamma_year3 ~ normal(0, 0.5);
  gamma_year4 ~ normal(0, 0.5);

  // --------------------------------
  // Priors: rater parameters
  // --------------------------------

  mu_a ~ normal(0, .75); // a_pop presumed to be in about .23 to .77
  sigma_a ~ normal(0, 1);
  z_a ~ std_normal();

  mu_p ~ normal(0, .75); 
  sigma_p ~ normal(0, 1);
  z_p ~ std_normal();
  delta_p3 ~ normal(0, 0.75);
  delta_p4 ~ normal(0, 0.75);
  
  // --------------------------------
  // Rating likelihood
  // --------------------------------

  // Accumulate rating evidence separately for
  // T_m = 0 and T_m = 1.
  for (n in 1:N) {
    int m = occasion_index[n];
    int j = rater_index[n];
    int y = year_index[m] + 1;
    real pj = p[j, y];

    real lpi_00 = log1m((1 - a[j]) * pj);
    real lpi_01 = log((1 - a[j]) * pj);
    real lpi_10 = log((1 - a[j]) * (1 - pj));
    real lpi_11 = log(a[j] + (1 - a[j]) * pj);

    if (rating[n] == 1) {
      log_L0[m] += lpi_01;
      log_L1[m] += lpi_11;
    } else {
      log_L0[m] += lpi_00;
      log_L1[m] += lpi_10;
    }
  }

  // Marginalize latent binary proficiency T_m.
  for (m in 1:M) {
    target += log_sum_exp(
      log_inv_logit(eta_t[m]) +
        log_L1[m],

      log1m_inv_logit(eta_t[m]) +
        log_L0[m]
    );
  }
}

generated quantities {
  vector[M] q;

  real a_pop = inv_logit(mu_a);
  real p_pop = inv_logit(mu_p);

  vector[M] log_L0 = rep_vector(0.0, M);
  vector[M] log_L1 = rep_vector(0.0, M);
  
  // full posterior predictive replication:
  // GPA + year -> t -> T_rep_full -> ratings

  // conditional replication:
  // observed ratings -> q -> T_rep_cond -> ratings

  array[M] int<lower=0, upper=1> T_rep_full;
  array[M] int<lower=0, upper=1> T_rep_cond;

  array[N] int<lower=0, upper=1> rating_rep_full;
  array[N] int<lower=0, upper=1> rating_rep_cond;
  
  // for calibration plots
  vector[N] pr1_full;
  vector[N] pr1_cond;
  

  // ------------------------------
  // posterior class probabilities
  // ------------------------------

  for (n in 1:N) {
    int m = occasion_index[n];
    int j = rater_index[n];
    int y = year_index[m] + 1;
    real pj = p[j, y];

    real lpi_00 = log1m((1 - a[j]) * pj);
    real lpi_01 = log((1 - a[j]) * pj);
    real lpi_10 = log((1 - a[j]) * (1 - pj));
    real lpi_11 = log(a[j] + (1 - a[j]) * pj);

    if (rating[n] == 1) {
      log_L0[m] += lpi_01;
      log_L1[m] += lpi_11;
    } else {
      log_L0[m] += lpi_00;
      log_L1[m] += lpi_10;
    }
  }

  for (m in 1:M) {
    q[m] = inv_logit(
      eta_t[m] +
      log_L1[m] -
      log_L0[m]
    );
  }

  // ------------------------------
  // posterior predictive data
  // ------------------------------

  // Generate a new latent true class for each occasion for both the
  // gpa + year generative model and the posterior q
  for (m in 1:M) {
    // full generative replication
    T_rep_full[m] = bernoulli_rng(t[m]);
  
    // conditional on ratings' information about latent truth
    T_rep_cond[m] = bernoulli_rng(q[m]);
  }

  // Generate a new set of ratings
  for (n in 1:N) {
    int m = occasion_index[n];
    int j = rater_index[n];
    int y = year_index[m] + 1;
    real pj = p[j, y];
    real pr1_full_sim;
    real pr1_cond_sim;

    // Marginal probability of a Class-1 rating
    // under the full GPA + year model
    pr1_full[n] =
      a[j] * t[m] +
      (1 - a[j]) * pj;
  
    // Marginal probability of a Class-1 rating
    // conditional on posterior class probability q
    pr1_cond[n] =
      a[j] * q[m] +
      (1 - a[j]) * pj;


    // Simulated ratings based on simulated truth values
    if (T_rep_full[m] == 1) {
      pr1_full_sim = a[j] + (1 - a[j]) * pj;
    } else {
      pr1_full_sim = (1 - a[j]) * pj;
    }
    
    if (T_rep_cond[m] == 1) {
      pr1_cond_sim = a[j] + (1 - a[j]) * pj;
    } else {
      pr1_cond_sim = (1 - a[j]) * pj;
    }

    rating_rep_full[n] = bernoulli_rng(pr1_full_sim);
    rating_rep_cond[n] = bernoulli_rng(pr1_cond_sim);
  }
}
Show the code
# execute or pull from disk?
if(0){
  stan_file <- "code/Example_writing3.stan"

  compiled_model <- cmdstanr::cmdstan_model(stan_file)

  stan_data <- list(
    N = nrow(dasl),
    I = n_distinct(dasl$subject_id), 
    R = n_distinct(dasl$rater_id),
    M = n_distinct(dasl$occasion_id),
    gpa_std = gpa_std,
    year_index = year_index,
    rating = dasl$rating,
    student_index = student_index, # see above
    rater_index = dasl$rater_id,
    occasion_index = dasl$occasion_id)
  
  fitted_model <- compiled_model$sample(
    data = stan_data,
  #  init = init_values,
    seed = 123,
    chains = 4,
    parallel_chains = 4,
    iter_warmup = 1000,
    iter_sampling = 1000,
    adapt_delta = 0.95,
    max_treedepth = 12,
    refresh = 1000)
  
  #shinystan::launch_shinystan(fitted_model)
  fitted_model$diagnostic_summary()

   fitted_model$save_object(file = "data/Example_writing2.rds")
  
} else {
  fitted_model <- read_rds("data/Example_writing2.rds")
}

qt_est <- fitted_model$draws(
  variables = c("q","t"),
  format = "draws_df"
) |> 
  summarise(across(everything(),mean)) |> 
  gather(var, value) |> 
  mutate( param = str_sub(var, 1,1 ),
          occasion_id = as.integer(str_extract(var,"\\d+"))) |> 
  filter(param %in% c("q","t")) |> 
  select(param, occasion_id, value) |> 
  spread(param, value)  |> 
  left_join(dasl |> group_by(occasion_id, year, subject_id) |> summarize(n_rating = n(), rating_avg = mean(rating))) |> 
  ungroup() 

p_est <- fitted_model$draws(
  variables = "p",
  format = "draws_df"
) |>
  select(starts_with("p[")) |>
   summarise(across(everything(),mean)) |> 
  pivot_longer(
    starts_with("p["),
    names_to = "param",
    values_to = "p"
  ) |>
  extract(
    param,
    into = c("rater_id", "year_index"),
    regex = "p\\[(\\d+),(\\d+)\\]",
    convert = TRUE
  ) |>
  mutate(
    year = year_index + 1
  )

a_est <- fitted_model$draws(
  variables = c("a"),
  format = "draws_df"
) |> 
  summarise(across(everything(),mean)) |> 
  gather(var, value) |> 
  mutate( param = str_sub(var, 1,1 ),
          rater_id = as.integer(str_extract(var,"\\d+"))) |> 
  filter(param %in% c("a")) |> 
  select(param, rater_id, value) |> 
  spread(param, value) |> 
  left_join(dasl |> group_by(rater_id, subject_id, year, occasion_id) |> summarize(n_rating = n(), rating_avg = mean(rating))) |> 
  ungroup() |> 
  left_join(p_est) |> 
  mutate(
    evidence_1 = log(
      (a + (1 - a) * p) /
        ((1 - a) * p)
    ),
    
    evidence_0 = log(
      ((1 - a) * (1 - p)) /
        (a + (1 - a) * (1 - p))
    ),
    
    n_1 = n_rating * rating_avg,
    n_0 = n_rating - n_1,
    
    logit_effect =
      n_1 * evidence_1 +
      n_0 * evidence_0
  ) |> 
  select(-n_0, -n_1, -year_index)

global_vars <- tribble(~variable, ~group,
                       "alpha_0", "t_m",
                       "alpha_gpa", "t_m",
                       "alpha_gpa2", "t_m",
                       "delta_year3","t_m",
                       "delta_year4","t_m",
                       "gamma_year3","t_m",
                       "gamma_year4","t_m",
                       "mu_a", "a_j",
                       "sigma_a", "a_j",
                       "mu_p", "p_j",
                       "sigma_p", "p_j",
                       "delta_p3", "p_j",
                       "delta_p4", "p_j")
  
# display the global model parameters
globals <- fitted_model$summary(variables = global_vars$variable) 

globals |> 
  left_join(global_vars) |> 
  select(group, variable, mean, median, q5, q95, rhat, ess_bulk, ess_tail) |> 
  kable(digits = c(0,0,rep(2,4), 3,0,0))
Table 3: Global parameters
group variable mean median q5 q95 rhat ess_bulk ess_tail
t_m alpha_0 0.72 0.72 0.34 1.09 1.003 1312 2074
t_m alpha_gpa 2.05 2.04 1.68 2.45 1.001 2618 2853
t_m alpha_gpa2 0.28 0.28 -0.02 0.56 1.002 3126 2696
t_m delta_year3 0.70 0.70 0.19 1.20 1.002 1508 2388
t_m delta_year4 1.19 1.19 0.66 1.74 1.006 1399 2135
t_m gamma_year3 0.63 0.63 0.08 1.19 1.000 3111 2851
t_m gamma_year4 0.24 0.23 -0.29 0.78 1.001 3098 2856
a_j mu_a -0.65 -0.64 -0.87 -0.43 1.002 1396 2135
a_j sigma_a 1.26 1.25 1.01 1.55 1.001 1107 2175
p_j mu_p 2.97 2.98 2.52 3.42 1.003 962 1640
p_j sigma_p 2.44 2.43 2.10 2.81 1.001 1133 1763
p_j delta_p3 -2.99 -2.99 -3.39 -2.60 1.003 1736 2535
p_j delta_p4 -4.87 -4.87 -5.43 -4.32 1.004 1465 2149

The rhat statistic is a diagnostic for agreement among MCMC chains. Values close to 1 are desirable; values above about 1.01 generally merit investigation. The final two columns give bulk and tail effective sample sizes, indicating how much independent information the autocorrelated MCMC draws contain. The diagnostics in Table 3 are generally satisfactory, although mu_p has the smallest effective sample size.

1.5.1 Class Priors (t_m)

The most important substantive conclusion is that the prior model for latent truth contributes substantial information. We have confidently non-zero estimates for most of the t_m model coefficients. The strongest result here is the GPA effect. The linear coefficient is 2.05, with its 90% interval of \([1.68,2.45]\) well above zero. Thus first-year college GPA is strongly associated with the latent probability of receiving a successful assessment. The quadratic term is much smaller, so there is some suggestion of upward curvature—GPA may become increasingly consequential toward the upper end—but the evidence for that feature is considerably weaker than for the basic GPA relationship.

1.5.2 Rater Accuracy (a_j)

The population center for rater accuracy is \(\mu_a=-0.65\), which corresponds to \(\text{logit}^{−1}(−0.65) \approx .34\). That’s a very low average rater accuracy, but there is large heterogeneity, with \(\sigma_a = 1.26\), so that a standard deviation above the mean is \(\text{logit}^{−1}(−0.65 + 1.26) \approx .65\). Low accuracy is to be expected given the non-standardized method of assessment.

1.5.3 Random Assignment (p_j)

Recall that the t-a-p model assumes that inaccurate ratings are randomly assigned, usually with a fixed probability of Class 1. Because of the calibration issues across years, we allowed each year to have a different intercept, with

\[ \operatorname{logit}(p_{jy}) = \mu_p+\sigma_pz_{p,j} +\delta_{p3}I(y=3) +\delta_{p4}I(y=4). \]

The population-center changes dramatically with assessment year, with

\[ \begin{aligned} \text{Year 2:}\quad& 2.97 &&\Rightarrow p\approx .95,\\ \text{Year 3:}\quad& 2.97-2.99=-.02 &&\Rightarrow p\approx .50,\\ \text{Year 4:}\quad& 2.97-4.87=-1.90 &&\Rightarrow p\approx .13. \end{aligned} \]

The default response reverses as the assessment becomes more advanced, reflecting the difficulty ramp we saw in the raw rating averages in Table 1.

The scale parameter \(\sigma_p=2.44\) implies larger rater-to-rater variation around those year-specific centers. These \(p_j\)s may seem like “nuisance parameters” designed to soak up variance and let the rest of the model work, but as we’ll see in the examples below, they are critical to determining the credibility of individual ratings.

1.6 Rating Calibration

The prior predictive check didn’t have access to the ratings data or the GPA and year predictors associated with them. After estimating the parameters, we can ask how well the resulting generative model can simulate ratings that look like the data set. This is a type of posterior predictive check.

Show the code
breaks <- seq(0, 1, by = .1)

cal_compare <- fitted_model$draws(
  variables = c("pr1_cond","pr1_full"),
  format = "draws_df"
) |>
  filter(.draw %in% sample(unique(.draw), 150)) |>
  dplyr::select(.draw, starts_with("pr1_")) |>
  tidyr::pivot_longer(
    -.draw,
    names_to = "row",
    values_to = "pr"
  ) |>
  mutate(
    row_id = as.integer(stringr::str_extract(substr(row,5,20), "\\d+")),
    type   = if_else(substr(row,5,8) == "full" ,"GPA + Year","Posterior")
  ) |>
  select(-row) |> 
  left_join(
    dasl |>
      mutate(row_id = row_number()) |>
      select(row_id, rating, year),
    by = "row_id"
  ) 

# global means
cal_means <- cal_compare |> 
             group_by(.draw, type, year) |> 
             summarize(avg_est = mean(pr),
                       avg_emp = mean(rating))

cal_sum <- cal_compare |> 
  mutate(
    bin = cut(pr, breaks = breaks, include.lowest = TRUE)
  ) |>
  group_by(.draw, bin, type, year) |> 
  summarise(
    pred = mean(pr),
    obs  = mean(rating),
    n = n()
  )

cal_sum |> 
  ggplot(aes(x = pred, y = obs, group = .draw)) +
  geom_abline(
    intercept = 0,
    slope = 1,
    linetype = "dashed"
  ) +
  geom_point(aes(x = avg_est, y = avg_emp), data = cal_means, 
             color = "red",
             size = 1) +
  geom_line(alpha = .04) +
  coord_equal(xlim = c(0, 1), ylim = c(0, 1)) +
  theme_bw() +
  facet_grid(year~type) +
  xlab("Modeled Pr[rating = 1]") +
  ylab("Avg Rating")
Figure 6: Rating calibration by year, comparing the probability of an on-track rating (1) from the latent class model of GPA and Year (left) and with the full model that includes rater and subject parameters from the ratings (right). The plot shows 150 randomly chosen draws from the MCMC. The red points identify the means over estimated probabilities by draw, year, and type compared to the corresponding empirical rating means.

Before adding flexibility to the default (randomly assigned) choice parameters \(p_j\) that allow them to vary by year, the rating calibration was poor. Year two’s probabilities were underestimated and year four’s were overestimated. This was an effect of forcing a single \(p\) across all three years. Those calibration curves led me to go back and add intercepts for years 3 and 4. The final version, with calibration shown in Figure 6 uses these prior specifications in the model block:

  mu_p ~ normal(0, .75); 
  sigma_p ~ normal(0, 1);
  z_p ~ std_normal();
  delta_p3 ~ normal(0, 0.75);
  delta_p4 ~ normal(0, 0.75);

The idea is to partially pool individual rater parameters using an average \(\mu_p\) with a scale parameter \(\sigma_p\), and allow raters to each have a degree of variance from the mean \(z_p\) expressed in that common unit. The posterior check on rating calibration led to the addition of the two delta parameters, so that in simpler notation,

\[ \text{logit}(p_j) = \mu + \sigma z_j + \mathbb{I}(Y_m=3) \delta_{3} + \mathbb{I}(Y_m=4) \delta_{4}. \]

This is parsimonious in that it only adds two parameters, moving the default probability of inaccurate Class 1 ratings by the same amounts for all raters (on the logit scale).

1.7 Accuracy Consistency

Another posterior check is to see if the accuracy parameter estimates are consistent with the model assumptions. Rater accuracy \(a_j\) is designed to be the rate at which that rater’s ratings matches the true class after discounting randomly-assigned ratings. Recall that this “chance agreement adjustment” is the core intuition behind the original kappa statistics. I’ll call this rate of chance-adjusted matching the “hit rate”, which can be expressed as

\[ \text{hit rate} = \frac{1}{M} \sum_{m,j} \left[ R_{mj}q_m + \bar{R}_{mj} \bar{q}_m - \bar{a}_j(p_{mj} q_m + \bar{p}_{mj} \bar{q}_m) \right]. \] The notation is complicated because every occasion \(m\) potentially has multiple raters \(j\), and the \(p_j\) parameter is modified by the year of the occasion (year + subject = occasion), hence \(p_{mj}\) means the rater’s random assignment parameter for the year of occasion \(m\). This hit rate formula is an average over a sum with two components, each analogous to the logical XNOR (logical equivalence) gate \(f(x,y) = xy + \bar{x}\bar{y}\). The first, \(f(R_{mj},q_m)\) estimates the match rate between ratings and the true classes of the subjects. But the matches include inaccurate accidents, so the subtracted piece \(f(p_{mj}, q_m)\) removes the estimate for these accidents according to the t-a-p generative model.

Show the code
breaks <- seq(0, 1, by = .10)

dasl |> 
  left_join(a_est |> select(rater_id, a) |> distinct()) |> 
  left_join(p_est |> select(rater_id, p) |> distinct()) |> 
  select(rater_id, occasion_id, a, p, rating, year) |> 
  left_join(qt_est |> select(occasion_id, q)) |> 
  mutate(abin = cut(a, breaks = breaks, include.lowest = TRUE),
         error_rate = (1-a)*(q*p + (1-p)*(1-q)),
         match_rate = q*rating + (1-q)*(1-rating),
         hit_rate =  match_rate - error_rate) |> 
  group_by(abin, year) |> 
  summarize(match_rate = mean(match_rate),
            hit_rate = mean(hit_rate),
            N = n(),
            a = mean(a)) |> 
  ungroup() |> 
  ggplot(aes(x = a, y =  hit_rate, group = 1, size = N)) +
  geom_abline(slope = 1, intercept = 0, color = "red", linetype = "dashed") +
  geom_line(size = 1) +
  geom_point(color = "gray") +
  theme_bw() +
  ylab("Est. hit rate") +
  xlab("accuracy (a_j)") +
  facet_grid(~year)
Figure 7: Plots of rater accuracy versus the adjusted match between ratings and estimated class probabilities, using the t-a-p model to remove the accidental matches. Results are disaggregated by year.

The adjusted hit rate in Figure 7 closely tracks estimated rater accuracy, as implied by the t-a-p model, although the relationship varies somewhat by year. In particular, Year 2 shows systematically more agreement than predicted by the constant-accuracy model, suggesting that the assumption of stable rater accuracy across years may be an approximation.

1.8 Effect of the Prior Truth Model

Recall that we replaced a flat prior for latent class probability \(t_m\) with a more complicated dependency on grades and timing. How much does this prior contribute to the posterior estimate of Class 1 probability for a rating occasion?

Show the code
breaks <- seq(0, 1, by = .05)

qt_bins <- qt_est |> 
  mutate(bin = cut(t, breaks = breaks, include.lowest = TRUE)) |> 
  group_by(bin) |> 
  summarize(N = n(),
            t_bin = mean(t),
            q_bin = mean(q),
            label = NA_character_) 

qt_est |> 
  mutate(label = if_else(subject_id == 114 | subject_id == 395, occasion_id, NA_integer_),
         subject = if_else(subject_id %in% c(395, 114), as.character(subject_id), "")) |> 
  ggplot(aes(x = t, y = q, label = label, color = subject)) +
  geom_point(color = "gray") +
  geom_text(size = 4) +
  geom_line(aes(x = t_bin, y = q_bin), color = "black", data = qt_bins) +
  geom_abline(slope = 1, intercept = 0, color = "red", linetype = "dashed") +
  theme_bw() +
  labs(
    x = "Prior class probability from GPA and year, t_i",
    y = "Posterior class probability after ratings, q_m"
  )  +
  theme(legend.position = "none")
Figure 8: Comparison of the student ability estimate from GPA (the prior) with the final probability estimate of Class 1 (q_m) for that occasion after adding the ratings data. Occasions corresponding to subjects 114 (green) and 395 (blue) are called out in the plot. The red line is 1-1 and the black line averages q over bins of t.

The plot in Figure 8 illustrates the relationship between prior estimates of student ability from first year college grades and the year difficulty. The posterior estimate we’re calling \(q_m\) is occasion-specific, meaning a given student in a given year of college, and it combines student-level information (GPA multiplied by the regression coefficient) with timing (the year multiplied by the difficulty coefficient) to estimate a prior probability (meaning before we consider ratings) that the student is on track with writing development. The ratings data then supply more specific evidence about that occasion. A useful consequence of the Justified True Belief generative construction is a natural Bayesian decomposition of inference into prior and observational evidence.

Although ratings can substantially alter the estimated class probability for individual occasions, these changes balance out across occasions. The black line shows the average posterior probability (q_m) at different levels of the prior probability (t_m). Its close correspondence with the identity line is an expected property of a well-calibrated Bayesian model: before observing the ratings, the expected posterior probability is the prior probability. Thus, the GPA-and-year model establishes the baseline distribution of class probabilities, while the ratings redistribute those probabilities among individual occasions.

If the ratings had no impact on the posterior probability, all the points would lie on the diagonal 1-1 line of Figure 8. But the bands of points at top right and bottom left show that most posterior class probability estimates are being pulled toward \(q_m = 1\) or \(q_m = 0\) by the ratings evidence. The labeled points in the bottom right of Figure 8 illustrate the importance of the ratings data. For occasion 1232 (green marker), the ratings data did not move the posterior estimates of on-track classification much from the prior taken from grades and timing. However, for subject 395 (blue), the ratings overwhelmed the priors to produce probabilities near zero or one.

Show the code
qt_est |> 
  filter(subject_id %in% c(395, 114)) |> 
  select(subject_id, year, n_rating, rating_avg, t, q, occasion_id ) |> 
  arrange(subject_id, year) |> 
  kable(digits = 2, align = "c")
Table 4: Subject details for subjects 114 and 395.
subject_id year n_rating rating_avg t q occasion_id
114 3 7 0.14 0.85 0.16 520
114 4 6 0.17 0.74 0.68 1232
395 2 3 0.67 0.24 0.01 238
395 3 3 1.00 0.08 0.84 789

The rating averages in Table 4 illustrate the case of subject 114: low ratings pulled down the posterior estimate in both years 3 and 4, although the effect in year four was minimal. Subject 395 shows two reversals from the prior. In the second year, a rating average of .67 pulled down the already-low \(t_{238} = .24\) to \(q_{238} = .01\). In the third year, three unanimous ratings of on-track (Class 1) pulled up a low \(t_{789} = .08\) to \(q_{798} = .84\). Why is there a difference in the effect of the ratings?

As noted in Chapter 5, formulating latent class probability in the log-odds form has an elegant interpretation. The evidence for class probability \(q_m\) can be written as

\[ \begin{aligned} \operatorname{logit}(q_m) &= \underbrace{\operatorname{logit}(t_m)}_{\substack{\text{GPA and year}\\\text{prior evidence}}} + \underbrace{\sum_j \log \frac{P(Y_{jm}\mid T_m=1,a_j,p_{jy})} {P(Y_{jm}\mid T_m=0,a_j,p_{jy})}}_{\text{evidence supplied by the raters}} \\ &= \operatorname{logit}(t_m)+ \sum_j ( \log L^1_{mj} - \log L^0_{mj} )\\ &=: \operatorname{logit}(t_m)+ \sum_j E_{mj} \end{aligned} \]

where \(L^1_{mj} = \log P(Y_{jm}\mid T_m=1,a_j,p_{jy})\) is the rater-derived evidence for occasion \(m\) being Class 1, and I’ll define \(E_{mj}\) to be the summative evidence for Class 1 from rater \(j\) on occasion \(m\). Under the plain t-a-p generative model, for rater \(j\),

\[ \begin{aligned} P(Y=1\mid T=1) &= a_j+(1-a_j)p_j \\ P(Y=1\mid T=0)&=(1-a_j)p_j\\ P(Y=0\mid T=1)&=(1-a_j)(1-p_j) \\ P(Y=0\mid T=0)&=a_j+(1-a_j)(1-p_j). \end{aligned} \]

Each observed rating by rater \(j\) at year \(y\) (which changes \(p_j\)), making occasion \(m\), has a log likelihood ratio in favor of \(T=1\) shown below. The \(L^0\) contributions are similarly derived.

\[ \begin{aligned} E_{mj}(\text{rating} =1) &= \log \frac{a_j+(1-a_j)p_{mj}} {(1-a_j)p_{mj}} \\ E_{mj}(\text{rating} =0) &= \log \frac{(1-a_j)(1-p_{mj})} {a_j+(1-a_j)(1-p_{mj})}. \end{aligned} \]

We can these formulas to quantify the effects of ratings in the cases identified in Figure 8. Table 5 gives details on the rater parameters involved in these cases.

Show the code
a_est |> 
  relocate(p, .after = a) |> 
  filter(subject_id %in% c(114, 395)) |> 
  arrange(subject_id, year) |> 
  rename(L_1 = evidence_1, L_0 = evidence_0, E_mj = logit_effect) |> 
  relocate(occasion_id) |> 
  kable(digits = 2, align = "c") 
Table 5: Rater details for subjects 114 and 395. The logit_effect column is L1 - L0.
occasion_id rater_id a p subject_id year n_rating rating_avg L_1 L_0 E_mj
520 18 0.45 0.22 114 3 2 0.0 1.56 -0.73 -1.46
520 54 0.29 0.56 114 3 1 0.0 0.56 -0.66 -0.66
520 55 0.42 0.23 114 3 2 0.0 1.42 -0.68 -1.35
520 62 0.22 0.72 114 3 1 1.0 0.34 -0.71 0.34
520 102 0.38 0.26 114 3 1 0.0 1.21 -0.61 -0.61
1232 24 0.32 0.12 114 4 1 0.0 1.57 -0.44 -0.44
1232 55 0.42 0.05 114 4 2 0.5 2.78 -0.57 2.20
1232 57 0.13 0.06 114 4 1 0.0 1.28 -0.15 -0.15
1232 76 0.54 0.35 114 4 1 0.0 1.48 -1.03 -1.03
1232 103 0.52 0.05 114 4 1 0.0 3.19 -0.77 -0.77
238 92 0.41 0.91 395 2 1 1.0 0.58 -2.15 0.58
238 109 0.65 0.98 395 2 1 0.0 1.06 -4.76 -4.76
238 143 0.26 0.89 395 2 1 1.0 0.33 -1.44 0.33
789 17 0.77 0.77 395 3 2 1.0 1.68 -2.74 3.36
789 189 0.65 0.76 395 3 1 1.0 1.23 -2.17 1.23

In Table 5, rater 55 has only \(a=.42\), and on occasion 1232 has \(p=.05\). When this rater fails to discriminate, they almost always emit a 0. Consequently, a rating of zero isn’t much evidence against \(T=1\) (log scale), with \(L^0_{1232,55}(0)=-0.57\), whereas a 1 rating is quite surprising under \(T=0\) with \(L^1_{1232,55}(1)=+2.78\). That rater’s two ratings, one 0 and one 1, produce \(E_{1232,55} = -0.57+2.78=+2.20\), which is a substantial net vote for \(T=1\), despite the raw rating average being exactly .5.

Across occasion 1232 the contributions are \(E_{1232} = -.44 + 2.20 -.15 -1.03 -.77 = -0.19\). There, the raw ratings are overwhelmingly negative (one positive rating out of six), but collectively they provide almost no net evidence either way. The lone positive from rater 55 essentially neutralizes the five negative ratings because those negative ratings mostly came from raters predisposed to produce zeros when they don’t successfully discriminate.

In occasion 238, rater 109 has \(a=.65,p=.98\). That’s almost the mirror image of the previous case: a 1 isn’t terribly surprising (\(+1.06\)), because this rater defaults overwhelmingly toward 1. But their observed 0 is quite diagnostic, with \(E_{238,109}(0)=-4.76\). The other two positive ratings contribute only \(.58+.33=.91\), so the three-rater combination gives net evidence of \(.91-4.76=-3.85\). Thus a raw majority of 2–1 in favor of 1 becomes very strong model evidence for \(T=0\).

These details reveal the inner workings of the model, showing how the rater parameters strongly influence the model’s evidence for class probabilities.

1.9 Model Comparisons

The original use of Item Response Theory requires that we know the correct answer to the test questions under analysis. It’s awkward when we have a collection of ratings instead, since are probably gathering ratings because we don’t know the true classification of each case. One solution, as in Engelhard Jr & Wind (2017), is to create a “gold standard” rating using expert raters than can then be used to assess the quality of other raters.

We have learned from the t-a-p analysis that when raters’ default inaccurate ratings have the same class proportions as the true classes \((p=t)\), the expected average rating equals the true class probability \(t\), regardless of rater accuracy. Consequently, the observed rating average provides a natural point of comparison with the posterior true-class probabilities \(q_m\), although those parameters also incorporates information about the individual raters and any explanatory model for \(t_m\), e.g. using GPA and year.

Show the code
tap_multi <- dasl |>
  group_nest(year) |>
  mutate(
    fit = map(
      data,
      ~ .x |>
        fit_ratings() |>
        as.list()
    )
  )|>
  select(fit) |>
  unnest_wider(fit) 

tap_em <- tap_multi |>
  mutate(year = list(2,3,4)) |> 
  select(year, subject_id, t) |>
  unnest(c(year, subject_id, t)) |>
  distinct(year, subject_id, t) |>
  rename(t_em = t)


irt <- glmer(
  rating ~ gpa*factor(year) + I(gpa^2) +
    (1 | rater_id) +
    (1 | occasion_id),
  data = dasl,
  family = binomial,
  control = glmerControl(
    optimizer = "bobyqa",
    optCtrl = list(maxfun = 2e5)
  )
)

occ_re <- ranef(irt)$occasion_id |>
  tibble::rownames_to_column("occasion_id") |>
  rename(occasion_re = `(Intercept)`) |> 
  mutate(occasion_id = as.integer(occasion_id))

occ_compare <- dasl |>
  distinct(occasion_id, year, gpa) %>%
  mutate(
    eta_fixed = predict(
      irt,
      newdata = .,
      re.form = NA,
      type = "link"
    )
  ) |>
  left_join(occ_re, by = "occasion_id") |>
  mutate(
    eta_irt = eta_fixed + occasion_re,
    pr_irt = plogis(eta_irt)
  )

breaks <- seq(0, 1, by = .1)

occ_sum <- occ_compare |> 
  select(occasion_id, pr_irt) |> 
  left_join(qt_est |> select(q, t, rating_avg, occasion_id, subject_id, year))  |> 
  left_join(tap_em) |> 
  mutate(
    bin = cut(q, breaks = breaks, include.lowest = TRUE)
  ) |>
  group_by( bin, year) |> 
  summarise(
    q = mean(q),
    t = mean(t),
    irt = mean(pr_irt),
    tap_em = mean(t_em),
    rating = mean(rating_avg)
  ) |> 
  gather(param, value, -year, -bin, -q)

occ_sum |> 
  ggplot(aes(x = q, y = value, group = param, color = param)) +
  geom_abline(
    intercept = 0,
    slope = 1,
    linetype = "dashed"
  ) +
  geom_line() +
scale_x_continuous(limits = c(0, 1)) +
scale_y_continuous(limits = c(0, 1)) +
  theme_bw() +
  facet_grid(~year) +
  xlab("t-a-p posterior Pr[T = 1]") +
  ylab("Probability") +
scale_color_discrete(
  labels = c(
    irt = "IRT/GLMM",
    rating = "Rating proportion",
    t = "Prior class probability (t)",
    tap_em = "t-a-p EM"
  )
)
Figure 9: Comparison of models, with the posterior class estimates (q_m) as the reference on the x-axis.

The IRT method has no way to separately calibrate rating expectations across the three years, so it’s overestimating class probabilities in year two and underestimating them in year four, where on-track ratings are scarcer. The IRT mismatch is not solely because of the multi-year data, because the plot for year four is essentially the same when IRT is fitted only to that year.

The comparison illustrates the consequence of treating a rating not as a noisy measurement of a continuous trait, but as evidence generated by an observer attempting to discriminate between latent states. Under the t-a-p construction, the question is therefore not simply how likely an occasion is to receive a positive rating, but how much the observed ratings should change our probability that the occasion truly belongs to the positive class.

References

Engelhard Jr, G., & Wind, S. (2017). Invariant measurement with raters and rating scales: Rasch models for rater-mediated assessments. Routledge.
Eubanks, D. A., Good, A., & Schramm-Possinger, M. (2020). Course grade reliability. Journal of Assessment and Institutional Effectiveness, 10(1-2), 85–111.
Eubanks, D., & Vanovac, S. (2020). Divergent writer development in college. The Journal of Writing Analytics, 4(1), 15–54.
Gelman, A., Vehtari, A., McElreath, R., Simpson, D., Margossian, C. C., Yao, Y., Kennedy, L., Gabry, J., Bürkner, P.-C., Modrák, M., et al. (2026). Bayesian workflow. CRC Press.