---
title: "Checking a reputation model"
description: "Three diagnostics for indirect reciprocity models in R: sensitivity to the benefit-to-cost ratio, replication across seeds, and drift in a finite population."
date: "2026-07-08 14:00"
date-modified: "2026-10-14"
categories: [evolutionary ecology, evolutionary game theory, model diagnostics, R, ecology tutorial]
image: thumbnail.png
image-alt: "Cooperation across ten random seeds under three assessment rules, image scoring scattering widely while standing and stern judging stay tight"
---
*Corrected 14 October 2026: check three called the ratio of the neutral fixation probability to the free rider's a measure of how much stronger selection is than drift; it now says only that a neutral mutant is that many times as likely to fix as the free rider.*
*Corrected 1 October 2026: the seed check ran fewer rounds than the post it checks and said image scoring's gain under private information was right on average; it now runs as many rounds, adds a long run in which every seed ends at zero, and says private information only slows the collapse. Check three said stern judging is the stricter rule only in large populations; it now says it is stricter at every size shown, by a margin that grows with population size.*
The three previous posts produced tidy results: a threshold at `q > c/b`, a clean split between assessment rules, and a reversal of that split under private information. Every one of those rests on choices that were never tested. The benefit and cost were fixed at 3 and 1. The agent-based runs used a single seed. Selection was treated as deterministic, in populations that are actually finite. This post runs the three checks that those choices invite, and one of the earlier results does not come through intact.
## Check 1: does the threshold depend on the payoffs?
The threshold `q > c/b` was derived with `b = 3` and `c = 1`, giving one third. The ratio is the only thing that enters, so the check is quick and the answer is reassuring in form but not in magnitude.
```{r}
#| label: ratio
for (ratio in c(1.5, 2, 3, 5, 10))
cat(sprintf("b/c = %4.1f reputation must be known more than %.2f of the time\n",
ratio, 1 / ratio))
```
The structure survives any ratio: there is always a threshold, and it always falls as helping gets cheaper relative to its benefit. What moves is how demanding the condition is. At a ratio of 2 a donor must know its recipient's record in more than half of all encounters, which is a strong requirement outside small groups. At a ratio of 10 one encounter in ten is enough.
That matters for interpreting field systems. Reporting that a species has a plausible `b/c` ratio says nothing on its own; the same ratio implies a demanding information requirement in one case and a lax one in another, and the information side is the harder one to measure.
The separatrix moves in the same direction, and more steeply.
```{r}
#| label: fig-ratio
#| fig-cap: "The starting fraction of discriminators needed for cooperation to take over, for four benefit-to-cost ratios. Each curve leaves the unit interval below its own threshold q = c/b."
#| fig-alt: "Four falling curves showing the required starting fraction of discriminators against information, lower curves for higher benefit-to-cost ratios."
library(ggplot2)
te_canvas <- theme(plot.background = element_rect(fill = "#f5f4ee", colour = NA),
panel.background = element_rect(fill = "#f5f4ee", colour = NA))
sep <- function(q, ratio) (1 - q) / (q * (ratio - 1)) # x* with c = 1, b = ratio
d <- do.call(rbind, lapply(c(2, 3, 5, 10), function(ratio) {
q <- seq(1 / ratio + 0.002, 1, 0.002)
data.frame(q = q, x = sep(q, ratio), ratio = factor(ratio))
}))
d <- d[d$x <= 1, ]
ggplot(d, aes(q, x, colour = ratio)) +
geom_line(linewidth = 0.9) +
scale_colour_manual(values = c("2" = "#b5534e", "3" = "#c9b458",
"5" = "#93a87f", "10" = "#275139")) +
labs(x = "Probability that reputation is known (q)",
y = "Starting fraction of discriminators needed", colour = "b/c") +
theme_minimal(base_size = 12) + te_canvas
```
## Check 2: is the private-information result one lucky seed?
The [private-information model](../public-and-private-reputation/) was run once per cell with the seed fixed at 449. A single run of an agent-based model is a single draw, and reporting it to three decimals implies a precision it has not earned. Repeat each rule across ten seeds at `q = 0.5`, for the same number of rounds as before, and look at the spread.
```{r}
#| label: sim
run <- function(q, rule, N = 100, rounds = 400, e = 0.02, seed = 1) {
set.seed(seed)
opinion <- matrix(1L, N, N)
coop <- numeric(rounds)
for (r in seq_len(rounds)) {
ord <- sample.int(N)
donors <- ord[1:(N / 2)]; recips <- ord[(N / 2 + 1):N]
helped <- 0
for (k in seq_along(donors)) {
d <- donors[k]; v <- recips[k]
act <- opinion[d, v] == 1L && runif(1) > e
helped <- helped + act
obs <- union(which(runif(N) < q), d)
rec_good <- opinion[cbind(obs, v)] == 1L
opinion[cbind(obs, d)] <- switch(rule,
standing = as.integer(act | !rec_good),
stern = as.integer(ifelse(rec_good, act, !act)),
scoring = as.integer(rep(act, length(obs))))
}
coop[r] <- helped / length(donors)
}
mean(tail(coop, 100))
}
```
```{r}
#| label: seeds
seeds <- 1:10
reps <- sapply(c("standing", "stern", "scoring"),
function(rule) sapply(seeds, function(s) run(0.5, rule, rounds = 500, seed = s)))
long_rounds <- 2000
long_run <- sapply(seeds, function(s) run(0.5, "scoring", rounds = long_rounds, seed = s))
round(rbind(mean = colMeans(reps), sd = apply(reps, 2, sd),
min = apply(reps, 2, min), max = apply(reps, 2, max)), 3)
```
Two of the three rules are solid. Standing gives `r sprintf("%.3f", mean(reps[, "standing"]))` with a standard deviation of `r sprintf("%.3f", sd(reps[, "standing"]))`, stern judging `r sprintf("%.3f", mean(reps[, "stern"]))` with `r sprintf("%.3f", sd(reps[, "stern"]))`. Neither ranking would change under any seed, and the collapse of stern judging to roughly half is a real feature of the rule rather than an artefact.
Image scoring is a different matter. Its mean of `r sprintf("%.3f", mean(reps[, "scoring"]))` comes with a standard deviation of `r sprintf("%.3f", sd(reps[, "scoring"]))` and a range from `r sprintf("%.3f", min(reps[, "scoring"]))` to `r sprintf("%.3f", max(reps[, "scoring"]))`, with `r sum(reps[, "scoring"] == 0)` of the `r length(seeds)` seeds already at zero. The spread has a simple cause. Once every opinion is bad nobody helps, every refusal is recorded as bad, and the implementation error can only turn help into refusal, so under image scoring a population in that state can never recover. Every run is heading there, and the seeds differ in how far each has got when the run stops. Run the same seeds for `r long_rounds` rounds and `r sum(long_run == 0)` of the `r length(seeds)` end with no cooperation at all. A single run of fixed length, like the one in the previous post, can make image scoring look as if it does better under private information, but it does not settle any higher: private information slows the collapse without preventing it, and any statement about the size of the effect needs the run length and the spread attached.
```{r}
#| label: fig-seeds
#| fig-cap: "Cooperation at q = 0.5 across ten random seeds. Standing and stern judging are tightly clustered; image scoring scatters widely, each run caught at a different point of its collapse, so its single-seed value carries little information."
#| fig-alt: "Dot plot of ten seed replicates per rule, tight clusters for standing and stern judging and a wide scatter for image scoring."
long <- data.frame(rule = rep(c("standing", "stern judging", "image scoring"), each = length(seeds)),
cooperation = as.vector(reps))
long$rule <- factor(long$rule, levels = c("standing", "stern judging", "image scoring"))
ggplot(long, aes(rule, cooperation, colour = rule)) +
geom_jitter(width = 0.12, height = 0, size = 2, alpha = 0.85) +
stat_summary(fun = mean, geom = "crossbar", width = 0.45, linewidth = 0.4, colour = "#16241d") +
scale_colour_manual(values = c(standing = "#275139", `stern judging` = "#b5534e",
`image scoring` = "#c9b458"), guide = "none") +
coord_cartesian(ylim = c(0, 1)) +
labs(x = NULL, y = "Cooperation rate") +
theme_minimal(base_size = 12) + te_canvas
```
## Check 3: is the free rider really removed?
The [assessment rules post](../assessment-rules-and-reputation/) reported that discriminators out-earn unconditional helpers by 0.0452 under standing and 0.1773 under stern judging, and treated both as selection against the second-order free rider. In an infinite population that is fair. In a finite one, a disadvantage that small competes with drift, and the right question is not the sign of the gap but the probability that the free rider takes over anyway.
The Moran process gives that probability directly. For a mutant with fitness ratio `r` in a population of `N`, the chance it reaches fixation is `(1 - 1/r) / (1 - 1/r^N)`, which reduces to `1/N` when `r` is one.
```{r}
#| label: fixation
b <- 3; cost <- 1
rules <- list(standing = matrix(c(1, 1, 0, 1), 2, 2),
`stern judging` = matrix(c(1, 0, 0, 1), 2, 2))
strategies <- list(DISC = c(1, 0), ALLC = c(1, 1))
payoffs <- function(rule, mix, e = 0.05, iters = 2000) {
A <- rules[[rule]]; nm <- names(mix)
g <- setNames(rep(1, length(mix)), nm)
for (it in seq_len(iters)) {
gbar <- sum(mix * g); prior <- c(gbar, 1 - gbar)
g_new <- sapply(nm, function(i) {
p <- strategies[[i]] * (1 - e); sum(prior * (p * A[, 1] + (1 - p) * A[, 2])) })
if (max(abs(g_new - g)) < 1e-12) { g <- g_new; break }
g <- g_new
}
gbar <- sum(mix * g)
helping <- sapply(nm, function(i) sum(c(gbar, 1 - gbar) * strategies[[i]] * (1 - e)))
received <- sapply(nm, function(i) sum(sapply(nm, function(j)
mix[j] * (1 - e) * (g[i] * strategies[[j]][1] + (1 - g[i]) * strategies[[j]][2]))))
-cost * helping + b * received
}
fixation <- function(r, N = 100) if (abs(r - 1) < 1e-12) 1 / N else (1 - 1 / r) / (1 - 1 / r^N)
for (rule in names(rules)) {
p <- payoffs(rule, c(DISC = 0.90, ALLC = 0.10))
rel <- p["ALLC"] / p["DISC"]
cat(sprintf("%-14s gap %+0.4f relative fitness %.4f fixation %.5f (neutral %.5f)\n",
rule, p["DISC"] - p["ALLC"], rel, fixation(rel), 0.01))
}
```
Under standing the free rider's relative fitness is 0.9752, giving a fixation probability of 0.00224 against the neutral 0.01. Selection is working, but a neutral mutant is only about four and a half times as likely to fix as the free rider, so in a population of a hundred an unconditional helper still takes over roughly once in every 450 introductions. Under stern judging relative fitness is 0.9030 and fixation rounds to zero at five decimal places, which is a different regime entirely.
The size of the population decides how much of this matters.
```{r}
#| label: fig-fixation
#| fig-cap: "Fixation probability of an unconditional helper introduced into a discriminating population, against population size. The dashed line is the neutral expectation 1/N; standing tracks it more closely than stern judging at every size."
#| fig-alt: "Fixation probability falling with population size on a log scale, a dashed neutral line above two curves for standing and stern judging."
Ns <- seq(20, 150, 5)
rel <- sapply(names(rules), function(rule) {
p <- payoffs(rule, c(DISC = 0.90, ALLC = 0.10)); as.numeric(p["ALLC"] / p["DISC"]) })
fx <- do.call(rbind, lapply(names(rules), function(rule)
data.frame(N = Ns, p = sapply(Ns, function(n) fixation(rel[[rule]], n)), rule = rule)))
neutral <- data.frame(N = Ns, p = 1 / Ns, rule = "neutral, 1/N")
ggplot(fx, aes(N, p, colour = rule, linetype = rule)) +
geom_line(data = neutral, linewidth = 0.9) +
geom_line(linewidth = 0.9) +
scale_y_log10(labels = scales::label_log()) +
scale_colour_manual(values = c(standing = "#275139", `stern judging` = "#b5534e",
`neutral, 1/N` = "#8d8d80")) +
scale_linetype_manual(values = c(standing = "solid", `stern judging` = "solid",
`neutral, 1/N` = "dashed")) +
labs(x = "Population size", y = "Fixation probability (log scale)",
colour = NULL, linetype = NULL) +
theme_minimal(base_size = 12) + te_canvas + theme(legend.position = "top")
```
In small groups the two rules are closer together, because drift counts for more against fitness deficits of `r sprintf("%.1f", 100 * (1 - rel[["standing"]]))` per cent under standing and `r sprintf("%.1f", 100 * (1 - rel[["stern judging"]]))` per cent under stern judging: at a population of `r min(Ns)` the free rider fixes with probability `r sprintf("%.3f", fixation(rel[["standing"]], min(Ns)))` under standing and `r sprintf("%.3f", fixation(rel[["stern judging"]], min(Ns)))` under stern judging, against the neutral `r 1 / min(Ns)`. The gap between them opens as the population grows. Stern judging is the stricter rule at every size shown, but how much stricter depends on the size of the population, and the model should say so.
## An honest limit
These checks probe the model's own assumptions, not its correspondence to any animal. Nothing here tells you whether a species tracks third-party reputation at all, which is the question a field study would have to answer first, and the evidence for it outside humans and a few cleaner fish systems is thin.
The fitness ratios in check 3 also come from the deterministic equilibrium and are then dropped into a Moran process, which mixes an infinite-population calculation with a finite-population one. A fully finite model would let reputations fluctuate with the composition of the population, and the fixation probabilities would move. The direction of the comparison is safe; the fifth decimal is not.
## References
Nowak MA, Sasaki A, Taylor C, Fudenberg D 2004. Nature 428(6983):646-650 (10.1038/nature02414)
Ohtsuki H, Iwasa Y 2006. Journal of Theoretical Biology 239(4):435-444 (10.1016/j.jtbi.2005.08.008)
Hilbe C, Schmid L, Tkadlec J, Chatterjee K, Nowak MA 2018. Proceedings of the National Academy of Sciences 115(48):12241-12246 (10.1073/pnas.1810565115)
## Related tutorials
- [Indirect reciprocity and reputation](../indirect-reciprocity-and-reputation/)
- [Assessment rules for reputation](../assessment-rules-and-reputation/)
- [Public and private reputation](../public-and-private-reputation/)
- [Checking a reciprocity model](../checking-a-reciprocity-model/)