Executive Summary
How 'Contract' and 'PaymentMethod' map together
Payment methods and contract types are weakly but significantly associated: Month-to-month contracts pair with Electronic check payments 1,850 times (548 more than independence predicts), while Two year contracts cluster with Credit card (automatic). Dimension 1 captures 100.0% of the association, running from short-term to long-term contracts on one axis and from manual to automatic payments on the other. All categories are well-represented on the map (100.0% quality), but the distance between a contract point and a payment point is not a measure of how strongly they go together—read direction from the origin instead.
Analysis Overview
Correspondence analysis of 'Contract' by 'PaymentMethod' across 7,043 observations.
Correspondence analysis maps the relationship between contract types and payment methods across 7,043 observations by decomposing a chi-square test into independent dimensions. Rather than answering only whether the two variables are related, this method shows how they are related by giving every category a coordinate on a shared map. The chi-square test rejects independence (p < 0.001), confirming there is a real pattern to visualize. Importantly, this analysis describes association—categories occurring together more or less often than chance would predict—not causation, since an unmeasured third factor could produce the same pattern.
Data Quality
Blank recoding, rare-category pooling, and the resulting table size.
All 7,043 rows entered the analysis without loss. The rare-category threshold of 71 observations (the larger of 5% of the data and 1) was applied to prevent isolated categories from distorting the map through sampling noise alone, but no categories fell below that threshold. Both 'Contract' and 'PaymentMethod' columns were complete with no blanks requiring recoding. The resulting 3 × 4 contingency table contains all observed data in its original form, ensuring the map reflects the full distribution without artificial pooling or removal.
Correspondence Biplot
'Contract' and 'PaymentMethod' categories on one map.
The map shows 3 contract types and 4 payment methods on a single pair of axes, with the origin representing the average profile. Dimension 1 (horizontal) carries 100.0% of the total inertia, creating a tight horizontal pattern: Month-to-month and Electronic check cluster at the negative end, while Two year and Credit card (automatic) cluster at the positive end. One year and Mailed check sit near the centre. Two year is the most distinctive category, furthest from the origin. The plane captures 100.0% of the association in the table. Critically, the gap between a contract point and a payment point is not interpretable as association strength because the two variable sets are scaled independently; instead, read categories that share direction from the origin—they occur together more often than expected.
Dimensions and Inertia Explained
How the total inertia of 0.1422 splits across 2 dimension(s).
The table's total inertia of 0.1422 splits into two dimensions. Dimension 1 explains 100.0% and Dimension 2 explains 0.0%, making the two-dimensional plane a faithful summary of all association in the table. The absence of meaningful variation on Dimension 2 reflects the fact that the primary pattern is one-dimensional: contract length and payment method automation run along a single axis. Inertia is chi-square divided by sample size, so these percentages partition the same quantity the independence test measures. Nothing is hidden off the plane.
Is There Anything to Map?
The test of independence and the total inertia the map divides up.
| Measure | Value | Interpretation |
|---|---|---|
| Total inertia | 0.1422 | Chi-square divided by the 7,043 observations — the total amount of association the map splits up. |
| Chi-square statistic | 1001.58 | How far the observed table sits from the counts independence would predict. |
| Degrees of freedom | 6 | (3 - 1) × (4 - 1). |
| P-value | < 0.001 | Independence is rejected at the 0.05 level, so there is a real pattern to map. |
| Cramér's V | 0.267 | Association strength is weak (0 = none, 1 = perfect; below 0.1 negligible, 0.1 to 0.3 weak, 0.3 to 0.5 moderate, above 0.5 strong). |
| Dimensions available | 2 | min(rows, columns) - 1 = 2 independent dimensions carry all of the inertia. |
| Inertia on dimensions 1 and 2 | 100.0% | The share of the association visible on the drawn map; the rest lives on 0 dimension(s) that are not drawn. |
The chi-square test yields 1001.58 on 6 degrees of freedom (p < 0.001), rejecting independence and confirming a real pattern exists. Total inertia is 0.1422 and Cramér's V is 0.267, indicating weak association strength. This distinction matters: with 7,043 observations, even a weak association clears the significance threshold, so the map shows a real but small effect. The weak strength (V = 0.267 falls in the 0.1–0.3 range) means contract type explains only a small portion of payment method variation and vice versa, though the pattern is statistically reliable.
Which Points Can Be Trusted
Per-category contribution to each dimension and quality of representation.
| Variable | Category | Mass PCT | Dim 1 | Dim 2 | Contribution Dim1 PCT | Contribution Dim2 PCT | Quality PCT | Reliability |
|---|---|---|---|---|---|---|---|---|
| Contract | Month-to-month | 55.02 | -0.3272 | -0.0005 | 41.4 | 3.6 | 100 | well represented |
| Contract | Two year | 24.07 | 0.5476 | -0.0022 | 50.8 | 25.2 | 100 | well represented |
| Contract | One year | 20.91 | 0.2306 | 0.0039 | 7.8 | 71.3 | 100 | well represented |
| PaymentMethod | Electronic check | 33.58 | -0.4859 | -0.0007 | 55.7 | 3.9 | 100 | well represented |
| PaymentMethod | Mailed check | 22.89 | -0.0087 | 0.0027 | 0 | 35.8 | 100 | well represented |
| PaymentMethod | Bank transfer (automatic) | 21.92 | 0.3543 | -0.0032 | 19.4 | 49 | 100 | well represented |
| PaymentMethod | Credit card (automatic) | 21.61 | 0.4047 | 0.0015 | 24.9 | 11.2 | 100 | well represented |
All seven categories are well-represented on the map. Two year contributes 50.8% of Dimension 1 on the Contract side and Electronic check contributes 55.7% on the PaymentMethod side, making them the dominant points. Month-to-month achieves 100.0% quality (best representation of its profile), and even Credit card (automatic), the lowest, reaches 100.0%. No category falls below 40% quality, so every plotted position reliably reflects that category's actual distribution across the other variable. A point far from the origin is not automatically trustworthy in other analyses, but here all distances are backed by good representation.
Reading the Biplot — and the One Rule Everyone Breaks
What each distance and direction on the 'Contract' by 'PaymentMethod' map does and does not mean.
| Rule | Detail |
|---|---|
| Distance between two 'Contract' points | Interpretable. Two 'Contract' categories that sit close together have similar profiles across 'PaymentMethod'. |
| Distance between two 'PaymentMethod' points | Interpretable. Two 'PaymentMethod' categories that sit close together have similar profiles across 'Contract'. |
| Distance from a point of 'Contract' to a point of 'PaymentMethod' | NOT interpretable as association strength. This is a symmetric map: each set of categories is scaled to its own inertia, so a short gap between a point of 'Contract' and a point of 'PaymentMethod' does not mean they go together. This is the mistake almost every reader makes. |
| Direction from the origin | Interpretable. A category of 'Contract' and a category of 'PaymentMethod' that lie in the same direction from the origin — a small angle at the origin — occur together more than independence predicts; opposite directions mean they occur together less. |
| Distance from the origin | Interpretable. The further a category sits from the origin, the more its profile departs from the average profile. A category at the origin is simply average. |
| How much of the map is real | Dimensions 1 and 2 carry 100.0% of the total inertia of 0.1422. What is not on this plane cannot be seen on it. |
| Points you should not interpret | Every plotted category has at least 100.0% of its variation captured by these two dimensions, so all drawn positions carry meaning. |
| Pooled categories | No categories were pooled: every level of 'Contract' and 'PaymentMethod' carried at least 71 observations and is plotted on its own. |
| Method | Classical correspondence analysis: the standardized residual matrix of the 3 × 4 table is decomposed by singular value decomposition, and both sets of categories are drawn in principal coordinates. |
Within each variable, distances are interpretable: Two year and One year sit relatively close together (similar PaymentMethod profiles), as do Bank transfer (automatic) and Credit card (automatic) (similar Contract profiles). Direction from the origin is the key rule: Month-to-month and Electronic check point the same way (negative Dimension 1), and their standardized residual of 27.83 confirms they occur together far more than independence predicts. Two year and Credit card (automatic) point the same way (positive Dimension 1) with a standardized residual of 14.54. The distance between a Contract point and a PaymentMethod point is NOT a measure of association—this symmetric map scales each variable independently, so that gap mixes two different yardsticks. No categories were pooled, and all 100.0% of inertia is on the drawn plane.
Correspondence Analysis — How Two Categorical Variables Map Together
Builds the two-way contingency table from two mapped categorical columns (or from a pre-aggregated count column), decomposes its chi-square residuals by singular value decomposition, and places both sets of categories on one map: the biplot.
Why This Method?
A chi-square test answers WHETHER two categorical variables are related. Correspondence analysis answers HOW: it splits the table's total inertia (chi-square divided by the sample size) into independent dimensions and gives every category a coordinate, so the pattern behind a significant test becomes readable instead of merely certain.
What This Analysis Covers
- Total inertia and the chi-square test of independence
- The dimension (scree) table with the share of inertia each explains
- Row and column coordinates on the first two dimensions
- The symmetric biplot with both sets of categories on one map
- Per-category contribution and quality of representation (cos-squared)
- The reading rules, including the row-to-column distance trap
Standard Library
Platform standard-library module (LAT-1441): runs on ANY dataset via the semantic mapping {row_var, col_var, count}. All narrative is derived from the user's own column names and computed values. The decomposition uses base svd only — no correspondence-analysis package is required.
suppressPackageStartupMessages(library(DT))
suppressPackageStartupMessages(library(htmlwidgets))
suppressPackageStartupMessages(library(arrow))
suppressPackageStartupMessages(library(knitr))
suppressPackageStartupMessages(library(rmarkdown))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(tidyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(stringr))
suppressPackageStartupMessages(library(lubridate))
suppressPackageStartupMessages(library(broom))
suppressPackageStartupMessages(library(Matrix))
suppressPackageStartupMessages(library(cluster))
suppressPackageStartupMessages(library(data.table))Formatting helpers — prose must never carry e-notation or bare asterisks
Core Analysis Pipeline
compute_shared <- function(df, params, col_map = list()) {
# === SHARED EXPORTS ===
# initial_rows/final_rows/rows_removed $ row accounting
# name_row / name_col / name_count $ humanized user column names
# has_count $ logical — pre-aggregated input used
# tab $ contingency table (rows x cols)
# n_obs $ total observations (sum of counts)
# levels_row / levels_col $ level labels in the table
# n_missing_row/_col $ blanks recoded to "Missing"
# n_lumped_row/_col $ levels folded into "Other"
# w_lumped_row/_col $ observations behind those levels
# rare_min $ the stated lumping threshold
# eig_df $ dimension/scree table
# n_dims / lam / total_inertia $ decomposition
# pct_plane $ % inertia on dimensions 1 and 2
# coords_row / coords_col $ principal coordinates (matrices)
# biplot_df $ dim_1, dim_2, point_type, category, ...
# point_quality_df $ per-category contribution + cos2
# assoc_df $ inertia / chi-square / Cramer's V table
# reading_df $ the reading rules, computed
# chi_stat/chi_df/chi_p $ chi-square test of independence
# cramers_v / strength_band $ effect size + band (sibling vocabulary)
# significant / map_interpretable $ logical
# pct_low_expected $ % of cells with expected count < 5
# top_over $ 1-row df — strongest over-representation
# same_direction / top_cos_angle $ biplot direction check for that cell
# low_quality_labels $ categories whose position is unreliable
# d1_neg/_pos, c1_neg/_pos $ the poles of dimension 1
# metrics / json_output
# === /SHARED EXPORTS ===Step 1: Discover the mapped columns
initial_rows <- nrow(df)
for (k in c("row_var", "col_var")) {
if (!k %in% names(df)) {
stop(sprintf("column_mapping must map '%s' to a categorical column.", k))
}
}
name_row <- humanize_semantic("row_var", col_map)
name_col <- humanize_semantic("col_var", col_map)
has_count <- "count" %in% names(df)
name_count <- if (has_count) humanize_semantic("count", col_map) else NA_character_Step 2: Weights — one per row, or the mapped count column
The count column is coerced with the 95% rule; a column that fails it is refused by name rather than silently treated as 1-per-row.
if (has_count) {
cv <- df[["count"]]
if (!is.numeric(cv)) {
conv <- suppressWarnings(as.numeric(as.character(cv)))
n_orig <- sum(!is.na(cv) & as.character(cv) != "")
if (n_orig > 0 && sum(!is.na(conv)) >= 0.95 * n_orig) {
cv <- conv
} else {
stop(sprintf(paste0("'%s' was mapped as the count column but it is not numeric ",
"(only %d of %d non-blank values convert to a number). ",
"Map a numeric count column, or leave it unmapped so that ",
"each row counts as one observation."),
name_count, sum(!is.na(conv)), n_orig))
}
}
cv <- as.numeric(cv)
cv[is.na(cv)] <- 0
if (any(cv < 0)) {
stop(sprintf("'%s' contains negative counts — a contingency table needs counts of zero or more.",
name_count))
}
w <- cv
} else {
w <- rep(1, initial_rows)
}
keep_rows <- w > 0
a_raw <- df[["row_var"]][keep_rows]
b_raw <- df[["col_var"]][keep_rows]
w <- w[keep_rows]
n_obs <- sum(w)Step 3: Minimum size — named for the user's own columns
if (n_obs < 30) {
stop(sprintf(paste0("Only %s observation(s) available across '%s' and '%s' — ",
"correspondence analysis needs at least 30. A table built from ",
"fewer observations gives coordinates that move substantially ",
"with a handful of rows."),
format(round(n_obs), big.mark = ","), name_row, name_col))
}Step 4: Identifier guard — a near-unique column is not a category
guard_identifier <- function(x, nm) {
nl <- length(unique(trimws(as.character(x))))
if (nl > 20 && nl > 0.5 * length(x)) {
stop(sprintf(paste0("'%s' has %s distinct values across %s rows — that is an ",
"identifier, not a category. Correspondence analysis needs two ",
"columns with a modest number of repeated categories."),
nm, format(nl, big.mark = ","), format(length(x), big.mark = ",")))
}
}
guard_identifier(a_raw, name_row)
guard_identifier(b_raw, name_col)Step 5: Clean and lump — blanks become "Missing"; rare levels become
"Other" against a stated threshold, because a category carried by a handful of observations lands far from the origin on noise alone and distorts the whole decomposition.
rare_min <- max(5, ceiling(0.01 * n_obs))
max_levels <- 8
prep_categorical <- function(x, wts, nm) {
x <- trimws(as.character(x))
blank <- is.na(x) | x == ""
n_missing <- sum(wts[blank])
x[blank] <- "Missing"
tw <- tapply(wts, x, sum)
tw <- tw[order(-tw)]
n_raw_levels <- length(tw)
rare <- names(tw)[tw < rare_min]
keep <- setdiff(names(tw), rare)
if (length(keep) > max_levels) {
rare <- c(rare, keep[(max_levels + 1):length(keep)])
keep <- keep[seq_len(max_levels)]
}
n_lumped <- length(rare)
w_lumped <- if (n_lumped > 0) sum(tw[rare]) else 0
if (n_lumped >= n_raw_levels) {
stop(sprintf(paste0("Every one of the %d categories in '%s' carries fewer than %d ",
"observations, so there is nothing left to compare once rare ",
"levels are pooled. Use a coarser grouping of '%s'."),
n_raw_levels, nm, rare_min, nm))
}
if (n_lumped > 0) x[x %in% rare] <- "Other"
tw2 <- tapply(wts, x, sum)
tw2 <- tw2[order(-tw2)]
lv <- names(tw2)
special <- intersect(c("Other", "Missing"), lv)
lv <- c(setdiff(lv, special), special)
list(x = factor(x, levels = lv), n_missing = n_missing,
n_lumped = n_lumped, w_lumped = w_lumped, n_raw_levels = n_raw_levels)
}
pa <- prep_categorical(a_raw, w, name_row)
pb <- prep_categorical(b_raw, w, name_col)Step 6: Degeneracy — a map needs at least a 3 x 3 table
A two-category column produces exactly one dimension, and a one-category column produces none; neither can be drawn as a two-dimensional map.
check_width <- function(p, nm) {
k <- nlevels(p$x)
if (k < 2) {
stop(sprintf(paste0("'%s' has only one distinct value (%s) after cleaning — ",
"correspondence analysis compares how categories differ from ",
"each other, so it needs at least three in each column."),
nm, levels(p$x)[1]))
}
if (k < 3) {
stop(sprintf(paste0("'%s' has only two categories (%s) after cleaning. A two-category ",
"column yields a single dimension, so there is no two-dimensional ",
"map to draw; test the association directly instead of mapping it."),
nm, oxford(levels(p$x))))
}
}
check_width(pa, name_row)
check_width(pb, name_col)
final_rows <- length(pa$x)
rows_removed <- initial_rows - final_rowsStep 7: Contingency table
tab <- tapply(w, list(pa$x, pb$x), sum)
tab[is.na(tab)] <- 0
tab <- as.matrix(tab)
dimnames(tab) <- list(levels(pa$x), levels(pb$x))Structural empties cannot enter the decomposition (their inverse mass is undefined); drop them and re-check the size.
keep_r <- rowSums(tab) > 0
keep_c <- colSums(tab) > 0
tab <- tab[keep_r, keep_c, drop = FALSE]
if (nrow(tab) < 3 || ncol(tab) < 3) {
stop(sprintf(paste0("The table of '%s' by '%s' collapsed to %d x %d once empty ",
"categories were removed — a map needs at least 3 x 3."),
name_row, name_col, nrow(tab), ncol(tab)))
}
levels_row <- rownames(tab)
levels_col <- colnames(tab)
n <- sum(tab)Step 8: Chi-square test of independence — the same test the
categorical-association tool runs, reported here so the map is never read without knowing whether there is anything to read.
chi <- suppressWarnings(chisq.test(tab, correct = FALSE))
chi_stat <- as.numeric(chi$statistic)
chi_df <- as.numeric(chi$parameter)
chi_p <- as.numeric(chi$p.value)
expected <- chi$expected
pct_low_expected <- 100 * mean(expected < 5)
significant <- !is.na(chi_p) && chi_p < 0.05Step 9: The decomposition — standardized residuals by base svd
P is the correspondence matrix, r and c the row and column masses, and S the matrix of standardized residuals whose squared singular values are the principal inertias. No correspondence-analysis package is used.
P <- tab / n
rm_ <- rowSums(P)
cm_ <- colSums(P)
S <- sweep(sweep(P - outer(rm_, cm_), 1, 1 / sqrt(rm_), "*"),
2, 1 / sqrt(cm_), "*")
sv <- svd(S)
n_dims <- min(nrow(tab), ncol(tab)) - 1
d <- sv$d[seq_len(n_dims)]
lam <- d^2
total_inertia <- sum(lam)Total inertia is chi-square divided by the sample size — this identity is what ties the map back to the test.
coords_row <- sweep(sv$u[, seq_len(n_dims), drop = FALSE] %*%
diag(d, n_dims, n_dims), 1, 1 / sqrt(rm_), "*")
coords_col <- sweep(sv$v[, seq_len(n_dims), drop = FALSE] %*%
diag(d, n_dims, n_dims), 1, 1 / sqrt(cm_), "*")
rownames(coords_row) <- levels_row
rownames(coords_col) <- levels_colSingular-vector signs are arbitrary; orient each dimension so its most extreme row category is positive, which makes the output reproducible.
for (k in seq_len(n_dims)) {
ix <- which_extreme(abs(coords_row[, k]), largest = TRUE)
if (!is.na(ix) && coords_row[ix, k] < 0) {
coords_row[, k] <- -coords_row[, k]
coords_col[, k] <- -coords_col[, k]
}
}Step 10: Contributions and quality of representation
Contribution: how much of a dimension's inertia one category creates. cos-squared: how much of a category's own distance from the average profile that dimension captures — the honest measure of whether the point's drawn position means anything.
contrib <- function(coords, mass) {
out <- matrix(NA_real_, nrow(coords), ncol(coords),
dimnames = dimnames(coords))
for (k in seq_len(ncol(coords))) {
if (is.finite(lam[k]) && lam[k] > 1e-12) {
out[, k] <- 100 * mass * coords[, k]^2 / lam[k]
}
}
out
}
cos2 <- function(coords) {
d2 <- rowSums(coords^2)
out <- matrix(NA_real_, nrow(coords), ncol(coords),
dimnames = dimnames(coords))
ok <- is.finite(d2) & d2 > 1e-12
if (any(ok)) out[ok, ] <- 100 * coords[ok, , drop = FALSE]^2 / d2[ok]
out
}
ctr_row <- contrib(coords_row, rm_)
ctr_col <- contrib(coords_col, cm_)
cos2_row <- cos2(coords_row)
cos2_col <- cos2(coords_col)
pct_dim <- 100 * lam / total_inertia
pct_plane <- if (n_dims >= 2) sum(pct_dim[1:2]) else pct_dim[1]
dim2_idx <- if (n_dims >= 2) 2 else 1
eig_df <- data.frame(
dimension = paste("Dimension", seq_len(n_dims)),
pct_inertia = round(pct_dim, 2),
eigenvalue = round(lam, 5),
cumulative_pct = round(cumsum(pct_dim), 2),
stringsAsFactors = FALSE
)Step 11: Biplot points — both sets of categories, one map
quality_plane_row <- if (n_dims >= 2) rowSums(cos2_row[, 1:2, drop = FALSE])
else cos2_row[, 1]
quality_plane_col <- if (n_dims >= 2) rowSums(cos2_col[, 1:2, drop = FALSE])
else cos2_col[, 1]
biplot_df <- rbind(
data.frame(
dim_1 = round(coords_row[, 1], 4),
dim_2 = round(coords_row[, dim2_idx], 4),
point_type = name_row,
category = levels_row,
mass_pct = round(100 * rm_, 2),
quality_pct = round(quality_plane_row, 1),
stringsAsFactors = FALSE
),
data.frame(
dim_1 = round(coords_col[, 1], 4),
dim_2 = round(coords_col[, dim2_idx], 4),
point_type = name_col,
category = levels_col,
mass_pct = round(100 * cm_, 2),
quality_pct = round(quality_plane_col, 1),
stringsAsFactors = FALSE
)
)
rownames(biplot_df) <- NULL
point_quality_df <- data.frame(
variable = biplot_df$point_type,
category = biplot_df$category,
mass_pct = biplot_df$mass_pct,
dim_1 = biplot_df$dim_1,
dim_2 = biplot_df$dim_2,
contribution_dim1_pct = round(c(ctr_row[, 1], ctr_col[, 1]), 1),
contribution_dim2_pct = round(c(ctr_row[, dim2_idx], ctr_col[, dim2_idx]), 1),
quality_pct = biplot_df$quality_pct,
stringsAsFactors = FALSE
)
point_quality_df$reliability <- ifelse(
is.na(point_quality_df$quality_pct), "not computable",
ifelse(point_quality_df$quality_pct >= 70, "well represented",
ifelse(point_quality_df$quality_pct >= 40, "partly represented",
"poorly represented — do not interpret its position")))
point_quality_df <- point_quality_df[order(-point_quality_df$quality_pct), ,
drop = FALSE]
rownames(point_quality_df) <- NULL
low_quality_labels <- point_quality_df$category[
!is.na(point_quality_df$quality_pct) & point_quality_df$quality_pct < 40]
min_quality <- if (all(is.na(point_quality_df$quality_pct))) NA_real_
else min(point_quality_df$quality_pct, na.rm = TRUE)Step 12: Poles of dimension 1 — what the main axis separates
pole <- function(coords) {
hi <- which_extreme(coords[, 1], largest = TRUE)
lo <- which_extreme(coords[, 1], largest = FALSE)
list(pos = if (is.na(hi)) NA_character_ else rownames(coords)[hi],
neg = if (is.na(lo)) NA_character_ else rownames(coords)[lo])
}
pr <- pole(coords_row)
pc <- pole(coords_col)Step 13: The strongest single over-representation — the sibling
tool's vocabulary (standardized residuals) reused deliberately.
obs_long <- as.data.frame(as.table(tab), stringsAsFactors = FALSE)
names(obs_long) <- c("level_row", "level_col", "observed")
exp_long <- as.data.frame(as.table(expected), stringsAsFactors = FALSE)
std_long <- as.data.frame(as.table(chi$stdres), stringsAsFactors = FALSE)
dev_all <- data.frame(
level_row = obs_long$level_row, level_col = obs_long$level_col,
cell = paste0(obs_long$level_row, " × ", obs_long$level_col),
observed = obs_long$observed,
expected = round(exp_long$Freq, 1),
std_residual = round(std_long$Freq, 2),
stringsAsFactors = FALSE
)
dev_all <- dev_all[is.finite(dev_all$std_residual), , drop = FALSE]
ix_over <- which_extreme(dev_all$std_residual, largest = TRUE)
top_over <- if (!is.na(ix_over) && dev_all$std_residual[ix_over] > 0)
dev_all[ix_over, , drop = FALSE] else NULLDirection check for that cell: in a symmetric map a row and a column category that go together point the same way from the origin. The cosine of the angle between the two position vectors is the computable form of that reading.
same_direction <- NA
top_cos_angle <- NA_real_
if (!is.null(top_over)) {
vr <- coords_row[top_over$level_row, c(1, dim2_idx)]
vc <- coords_col[top_over$level_col, c(1, dim2_idx)]
den <- sqrt(sum(vr^2)) * sqrt(sum(vc^2))
if (is.finite(den) && den > 1e-12) {
top_cos_angle <- sum(vr * vc) / den
same_direction <- top_cos_angle > 0
}
}Whether the two positive poles (and the two negative poles) genuinely co-occur more than independence predicts. Checked against the standardized residual of those two cells rather than asserted from the picture — the whole point of this tool is that the picture can mislead.
resid_of <- function(rl, cl) {
if (is.na(rl) || is.na(cl)) return(NA_real_)
ix <- which(dev_all$level_row == rl & dev_all$level_col == cl)
if (length(ix) == 1) dev_all$std_residual[ix] else NA_real_
}
pole_pos_resid <- resid_of(pr$pos, pc$pos)
pole_neg_resid <- resid_of(pr$neg, pc$neg)
poles_agree <- !is.na(pole_pos_resid) && !is.na(pole_neg_resid) &&
pole_pos_resid > 0 && pole_neg_resid > 0Step 14: Association strength — Cramer's V, same bands as the sibling
cramers_v <- sqrt(total_inertia / (min(dim(tab)) - 1))
strength_band <- if (is.na(cramers_v)) "unknown"
else if (cramers_v < 0.1) "negligible"
else if (cramers_v < 0.3) "weak"
else if (cramers_v < 0.5) "moderate"
else "strong"The map is only worth reading if the table departs from independence.
map_interpretable <- significant
assoc_df <- data.frame(
measure = c("Total inertia", "Chi-square statistic", "Degrees of freedom",
"P-value", "Cramér's V", "Dimensions available",
"Inertia on dimensions 1 and 2"),
value = c(fmt_num(total_inertia), fmt_num(chi_stat, 2),
format(chi_df), p_display(chi_p),
fmt_num(cramers_v, 3), format(n_dims), fmt_pct(pct_plane)),
interpretation = c(
paste0("Chi-square divided by the ", format(round(n), big.mark = ","),
" observations — the total amount of association the map splits up."),
"How far the observed table sits from the counts independence would predict.",
paste0("(", nrow(tab), " - 1) × (", ncol(tab), " - 1)."),
if (significant)
"Independence is rejected at the 0.05 level, so there is a real pattern to map."
else
"Independence is not rejected at the 0.05 level, so the map shows sampling noise.",
paste0("Association strength is ", strength_band,
" (0 = none, 1 = perfect; below 0.1 negligible, 0.1 to 0.3 weak, ",
"0.3 to 0.5 moderate, above 0.5 strong)."),
paste0("min(rows, columns) - 1 = ", n_dims,
" independent dimensions carry all of the inertia."),
paste0("The share of the association visible on the drawn map; the rest lives on ",
max(0, n_dims - 2), " dimension(s) that are not drawn.")
),
stringsAsFactors = FALSE
)Step 15: The reading rules, written with the user's own column names
unreliable_rule <- if (length(low_quality_labels) > 0) {
paste0(length(low_quality_labels), " categor",
if (length(low_quality_labels) == 1) "y is" else "ies are",
" represented by less than 40% on this plane(",
oxford(low_quality_labels),
"). Their drawn positions are mostly an artefact of dimensions that are ",
"not shown — do not read them.")
} else {
paste0("Every plotted category has at least ", fmt_pct(min_quality),
" of its variation captured by these two dimensions, so all drawn ",
"positions carry meaning.")
}
other_rule <- if (pa$n_lumped > 0 || pb$n_lumped > 0) {
paste0("The \"Other\" point is a pooled mixture of ",
pa$n_lumped + pb$n_lumped,
" rare categories, so its position is an average of unlike things and ",
"should not be interpreted as a category in its own right.")
} else {
paste0("No categories were pooled: every level of '", name_row, "' and '",
name_col, "' carried at least ", rare_min,
" observations and is plotted on its own.")
}
reading_df <- data.frame(
rule = c(
paste0("Distance between two '", name_row, "' points"),
paste0("Distance between two '", name_col, "' points"),
paste0("Distance from a point of '", name_row, "' to a point of '", name_col, "'"),
"Direction from the origin",
"Distance from the origin",
"How much of the map is real",
"Points you should not interpret",
"Pooled categories",
"Method"
),
detail = c(
paste0("Interpretable. Two '", name_row,
"' categories that sit close together have similar profiles across '",
name_col, "'."),
paste0("Interpretable. Two '", name_col,
"' categories that sit close together have similar profiles across '",
name_row, "'."),
paste0("NOT interpretable as association strength. This is a symmetric map: ",
"each set of categories is scaled to its own inertia, so a short gap ",
"between a point of '", name_row, "' and a point of '", name_col,
"' does not mean they go together. This is the mistake almost ",
"every reader makes."),
paste0("Interpretable. A category of '", name_row, "' and a category of '", name_col,
"' that lie in the same direction from the origin — a small ",
"angle at the origin — occur together more than independence predicts; ",
"opposite directions mean they occur together less."),
paste0("Interpretable. The further a category sits from the origin, the more ",
"its profile departs from the average profile. A category at the origin ",
"is simply average."),
paste0("Dimensions 1 and 2 carry ", fmt_pct(pct_plane),
" of the total inertia of ", fmt_num(total_inertia),
". What is not on this plane cannot be seen on it."),
unreliable_rule,
other_rule,
paste0("Classical correspondence analysis: the standardized residual matrix ",
"of the ", nrow(tab), " × ", ncol(tab),
" table is decomposed by singular value decomposition, and both sets ",
"of categories are drawn in principal coordinates.")
),
stringsAsFactors = FALSE
)
metrics <- list(
`Observations` = as.integer(round(n)),
`Table Size` = paste0(nrow(tab), " × ", ncol(tab)),
`Total Inertia` = round(total_inertia, 4),
`Chi-Square` = round(chi_stat, 2),
`P Value` = p_display(chi_p),
`Cramér's V` = round(cramers_v, 3),
`Dim 1+2 Inertia` = fmt_pct(pct_plane),
`Association` = if (significant) paste0("associated(", strength_band, ")")
else "not associated"
)
answer <- if (map_interpretable) {
paste0(
"Correspondence analysis of '", name_row, "' by '", name_col, "' over ",
format(round(n), big.mark = ","), " observations in a ", nrow(tab), " × ",
ncol(tab), " table: total inertia ", fmt_num(total_inertia),
" (chi-square ", fmt_num(chi_stat, 2), ", ", p_phrase(chi_p),
"; Cramér's V ", fmt_num(cramers_v, 3), ", ", strength_band,
"). Dimension 1 carries ", fmt_pct(pct_dim[1]),
" of that inertia and separates ", pr$neg, " from ", pr$pos, " on the '",
name_row, "' side and ", pc$neg, " from ", pc$pos, " on the '", name_col,
"' side; dimensions 1 and 2 together show ", fmt_pct(pct_plane), ".",
if (!is.null(top_over)) paste0(
" The strongest over-representation is ", top_over$cell, " (",
format(round(top_over$observed), big.mark = ","), " observed vs ",
format(top_over$expected, big.mark = ","), " expected).") else "",
" Read the map by direction from the origin: in a symmetric map the distance ",
"from a point of '", name_row, "' to a point of '", name_col,
"' is not a measure of how strongly they go together."
)
} else {
paste0(
"Correspondence analysis of '", name_row, "' by '", name_col, "' over ",
format(round(n), big.mark = ","), " observations in a ", nrow(tab), " × ",
ncol(tab), " table finds no association to map: total inertia is only ",
fmt_num(total_inertia), " and the chi-square test of independence does not ",
"reject independence(", p_phrase(chi_p), "; Cramér's V ",
fmt_num(cramers_v, 3), ", ", strength_band,
"). The coordinates still exist and are still plotted, but they describe ",
"sampling noise rather than structure and should not be interpreted."
)
}
json_output <- list(
answer = answer,
cards = lapply(
c("tldr", "overview", "preprocessing", "biplot", "dimension_summary",
"association_summary", "point_quality", "reading_the_map"),
function(cid) list(id = cid, metrics = metrics)
)
)
list(
initial_rows = initial_rows, final_rows = final_rows,
rows_removed = rows_removed,
name_row = name_row, name_col = name_col, name_count = name_count,
has_count = has_count,
tab = tab, n_obs = n, levels_row = levels_row, levels_col = levels_col,
n_missing_row = pa$n_missing, n_missing_col = pb$n_missing,
n_lumped_row = pa$n_lumped, n_lumped_col = pb$n_lumped,
w_lumped_row = pa$w_lumped, w_lumped_col = pb$w_lumped,
n_raw_levels_row = pa$n_raw_levels, n_raw_levels_col = pb$n_raw_levels,
rare_min = rare_min, max_levels = max_levels,
eig_df = eig_df, n_dims = n_dims, lam = lam, pct_dim = pct_dim,
total_inertia = total_inertia, pct_plane = pct_plane,
coords_row = coords_row, coords_col = coords_col,
biplot_df = biplot_df, point_quality_df = point_quality_df,
assoc_df = assoc_df, reading_df = reading_df,
chi_stat = chi_stat, chi_df = chi_df, chi_p = chi_p,
pct_low_expected = pct_low_expected,
cramers_v = cramers_v, strength_band = strength_band,
significant = significant, map_interpretable = map_interpretable,
top_over = top_over, same_direction = same_direction,
top_cos_angle = top_cos_angle,
pole_pos_resid = pole_pos_resid, pole_neg_resid = pole_neg_resid,
poles_agree = poles_agree,
low_quality_labels = low_quality_labels, min_quality = min_quality,
d1_pos = pr$pos, d1_neg = pr$neg, c1_pos = pc$pos, c1_neg = pc$neg,
metrics = metrics, json_output = json_output
)
}Row and column contributions each sum to 100% within their own variable, so the top contributor is reported per variable — pooling the two would compare shares of two different totals.
top_of <- function(v) {
sub <- pq[pq$variable == v, , drop = FALSE]
sub[order(-sub$contribution_dim1_pct), , drop = FALSE][1, , drop = FALSE]
}
top_r <- top_of(shared$name_row)
top_c <- top_of(shared$name_col)
n_poor <- sum(!is.na(pq$quality_pct) & pq$quality_pct < 40)
list(
title = "Which Points Can Be Trusted",
description = "Per-category contribution to each dimension and quality of representation.",
text = paste0(
"Two numbers decide whether a point's position means anything. ",
"Contribution says how much of a dimension that category creates; the ",
"'", shared$name_row, "' categories account for 100% of each dimension ",
"between them and the '", shared$name_col,
"' categories independently account for another 100%, so they are read ",
"within a variable, not across the two. On dimension 1 that is ",
top_r$category, " at ", fmt_pct(top_r$contribution_dim1_pct), " of the '",
shared$name_row, "' side and ", top_c$category, " at ",
fmt_pct(top_c$contribution_dim1_pct), " of the '", shared$name_col,
"' side. Quality (cos-squared) says how much of a category's own ",
"distance from the average profile these two dimensions capture — ",
best$category, " is best represented at ", fmt_pct(best$quality_pct),
", while ", worst$category, " is worst at ", fmt_pct(worst$quality_pct), ". ",
if (n_poor > 0)
paste0(n_poor, " categor", if (n_poor == 1) "y falls" else "ies fall",
" below 40% and ", if (n_poor == 1) "is" else "are",
" marked as not interpretable: ",
if (n_poor == 1) "it lies" else "they lie",
" where the drawn plane happens to project ",
if (n_poor == 1) "it" else "them",
", not where ", if (n_poor == 1) "its" else "their",
" profile actually differs.")
else
paste0("No category falls below 40%, so every drawn position is a fair ",
"summary of that category's profile."),
" A category with low quality can still sit far from the origin on the ",
"map — that is exactly why the picture alone is not enough."
),
data = list(point_quality = pq)
)
}
# Card: reading_the_map (table)
card_reading_the_map <- function(shared, df, params) {
list(
title = "Reading the Biplot — and the One Rule Everyone Breaks",
description = paste0("What each distance and direction on the '",
shared$name_row, "' by '", shared$name_col,
"' map does and does not mean."),
text = paste0(
"The single most common error in reading a correspondence biplot is ",
"measuring how close a point of '", shared$name_row, "' sits to a point of '",
shared$name_col, "' and calling that the strength of their ",
"association. In this symmetric map it is not. Both sets are drawn in ",
"principal coordinates, each scaled to its own inertia, so the two clouds ",
"have no common yardstick: the gap between a point of '", shared$name_row,
"' and a point of '", shared$name_col,
"' mixes two different scales and is not a quantity. What IS ",
"interpretable is distance within each set, direction from the origin ",
"across the sets, and distance from the origin as departure from the ",
"average profile. ",
if (shared$map_interpretable && isTRUE(shared$poles_agree))
paste0("Applied here: ", shared$d1_pos, " and ", shared$c1_pos,
" both sit at the positive end of dimension 1 while ",
shared$d1_neg, " and ", shared$c1_neg,
" sit at the negative end. The table confirms what that shared ",
"direction implies — ", shared$d1_pos, " × ", shared$c1_pos,
" has a standardized residual of ", fmt_num(shared$pole_pos_resid, 2),
" and ", shared$d1_neg, " × ", shared$c1_neg, " one of ",
fmt_num(shared$pole_neg_resid, 2),
", both above what independence predicts. Read from the direction ",
"they share, not from how far apart they are drawn.")
else if (shared$map_interpretable)
paste0("Applied here with a caveat: ", shared$d1_pos, " and ", shared$c1_pos,
" sit at the positive end of dimension 1 and ", shared$d1_neg,
" and ", shared$c1_neg, " at the negative end, but the ",
"standardized residuals of those two cells(",
fmt_num(shared$pole_pos_resid, 2), " and ",
fmt_num(shared$pole_neg_resid, 2),
") do not both exceed what independence predicts. Dimension 1 is ",
"separating profiles here rather than pairing individual ",
"categories — check the deviations before reading any single pair ",
"off the picture.")
else
paste0("None of it applies here, because the chi-square test does not ",
"reject independence(", p_phrase(shared$chi_p),
"): there is no association for any reading rule to recover."),
" The rows below spell out each rule for your own columns."
),
data = list(reading_rules = shared$reading_df)
)
}