ex <- as_tibble(cache$examples) |> mutate(s = pmin(ab_w / ab_n, bc_w / bc_n, ca_w / ca_n))
pick_row <- function(pat) { x <- filter(ex, grepl(pat, unit)); if (all(is.na(x$model_min))) x[which.max(x$s), ] else x[which.max(x$model_min), ] }
games <- function(w, n, what) sprintf("%g of %d %s", w, n, what)
# one example: `ids` are the three as named in the data, `lab` as shown, `standing`
# the overall measure the text orders them by (higher is better)
show_cycle <- function(title, intro, ids, lab, tab, standing, standing_txt, what) {
r <- attr(ids, "row")
edges <- list(c(1, 2, r$ab_w, r$ab_n), c(2, 3, r$bc_w, r$bc_n), c(3, 1, r$ca_w, r$ca_n))
rec <- sapply(edges, function(e) sprintf("%s beat %s (%s)", lab[e[1]], lab[e[2]], games(e[3], e[4], what)))
up <- sapply(edges, function(e) standing[e[1]] < standing[e[2]])
ord <- lab[order(-standing)]
cat("**", title, "** ", intro, "\n\n", sep = "")
cat(knitr::kable(tab, format = "pipe", align = c("l", rep("r", ncol(tab) - 1))), sep = "\n")
cat("\nHead to head: ", paste(rec, collapse = "; "), ". ", sep = "")
cat("By ", standing_txt, ", the order is ", paste(ord, collapse = " > "), ". The loop closes because ",
paste(rec[up], collapse = " and "), ", against that order.\n\n", sep = "")
}
if (!is.null(extras)) {
rk <- as_tibble(extras$risks)
risk_ex <- function(pat, table, title, intro, deaths) {
r <- pick_row(pat); ids <- c(r$A, r$B, r$C); attr(ids, "row") <- r
x <- rk[rk$table == table, ][match(ids, rk$risk[rk$table == table]), ]
tab <- tibble(Risk = ids, `Comparisons won, against all 99 other risks` = pct0(x$share_won))
if (deaths) tab$`Actual deaths, 2015` <- num(x$deaths_2015)
show_cycle(title, intro, ids, ids, tab, x$share_won, "the share of all comparisons won", "judgments")
if (deaths) cat("By actual deaths, the order is ", paste(ids[order(-x$deaths_2015)], collapse = " > "),
", and no loop is possible.\n\n", sep = "")
}
risk_ex("^friedman incidence", "friedman2019_risk_incidence", "Risks: which killed more people last year?",
"Each respondent saw two risks at a time and picked the one they thought killed more Americans in the last year. Actual deaths are Friedman's 2015 figures.", TRUE)
risk_ex("^friedman harm", "friedman2019_risk_harm", "Risks: which caused more harm to Americans last year?",
"The same design, asking which risk caused more harm. There is no objective measure of harm to compare with, so the table shows only how respondents ranked the three.", FALSE)
r <- pick_row("^lichess"); ids <- c(r$A, r$B, r$C); attr(ids, "row") <- r
pl <- as_tibble(extras$players) |> filter(unit == r$unit)
x <- pl[match(ids, pl$player), ]
mo <- month.name[as.integer(sub("lichess 2013-(\\d+) .*", "\\1", r$unit))]
lab <- paste("Player", 1:3)
show_cycle(paste0("Lichess bullet, ", mo, " 2013"),
sprintf("Three of the month's %d most active players.", nrow(pl)), ids, lab,
tibble(Player = lab, `Rating` = sprintf("%.0f", x$rating), `Games in the month` = x$games,
`Points won` = pct0(x$points / x$games)),
x$points / x$games, "points won in the month", "games")
r <- pick_row("^kaggle"); ids <- c(r$A, r$B, r$C); attr(ids, "row") <- r
bt <- as_tibble(extras$bots) |> filter(unit == r$unit) |> mutate(share = points / games, rank = rank(-share, ties.method = "min"))
x <- bt[match(ids, bt$bot), ]
lab <- paste("Bot", 1:3)
show_cycle(paste("Kaggle:", sub("^kaggle ", "", r$unit)),
sprintf("Three of the %d bots in the competition's dense core.", nrow(bt)), ids, lab,
tibble(Bot = lab, `Games` = x$games, `Points won` = pct0(x$share), `Rank by points` = paste(x$rank, "of", nrow(bt))),
x$share, "points won in the competition", "games")
}