Executive Summary
2 natural segments across 440 observations
The data splits into 2 natural spending profiles: a mainstream segment of 434 customers (98.6%) spending near the overall average, and a small specialized segment of 6 customers (1.4%) with very high Milk and Grocery purchases. Separation is strong (silhouette 0.792). The merge-height scree confirms k = 2 as the natural cut point. Milk is the feature that separates the segments most, with cluster averages spanning 5.19 standard deviations.
Analysis Overview
Hierarchical (Ward.D2) segmentation of 440 observations on 6 features.
This analysis standardizes 6 spending categories (Fresh, Milk, Grocery, Frozen, Detergents Paper, Delicassen) across 440 wholesale customers and builds a hierarchical cluster tree using Ward.D2 linkage. The full tree is constructed first—unlike k-means—so structure is visible at every scale before committing to a cluster count. Three linkage rules were tested; Ward.D2 was chosen because its compact, even-sized groups are most interpretable for segmentation despite average linkage preserving distances better (cophenetic correlation 0.934 vs. 0.415). The tree is cut at k = 2, chosen by average silhouette width (0.792, strong separation).
Data Quality
Column typing, imputation, standardization, and exclusions.
All 440 rows were retained; no rows were removed. Missing values were imputed using each column's median. All 6 mapped feature columns were usable; no features were dropped. All features were standardized (mean 0, sd 1) before distance calculation to ensure no single category dominates the tree. Standardization is essential here because spending volumes vary widely across product types; without it, a high-volume category would artificially drive the clustering.
Where the Tree Cuts
Merge height of the final merges — the dendrogram's scree.
The merge-height scree shows a steep jump between 2 and 3 clusters remaining: the gap falls from 27.461 (at k = 2) to 24.651 (at k = 3), a drop of 3.0 units. This is the largest single step in the final 30 merges, marking where the tree was forced to weld together genuinely distant groups. The location of this gap agrees with the silhouette-chosen k = 2, providing independent confirmation that 2 segments is the natural structure in the data.
How Many Clusters?
Average silhouette width for each candidate cut of the tree.
Silhouette width peaks sharply at k = 2 (0.792, strong separation), then drops dramatically to k = 3 (0.265, reasonable). All other candidate cuts (k = 4 through k = 10) remain in the reasonable band (0.24–0.28), with k = 10 as the runner-up at 0.28. The steep cliff from k = 2 to k = 3 indicates a real, stable property of the data rather than an arbitrary choice; additional cuts would trade clarity for false precision.
Segment Map
2-D PCA projection of all features, colored by segment.
The 2-D PCA projection (capturing 72.5% of total variance: 44.1% on PC1, 28.4% on PC2) shows the two segments as visually distinct islands. The mainstream segment (C1, 434 rows) forms a dense cloud near the origin. The small specialized segment (C2, 6 rows) appears as isolated points far from the main group, confirming strong separation. The tight clustering of C1 and clear separation of C2 align with the strong silhouette score (0.792).
Segment Profiles
Per-segment feature averages in standard-deviation units.
C1 (Near overall average) sits close to zero across all features (z-scores from −0.07 to −0.02), defining customers who spend in line with the overall portfolio. C2 (High Milk, High Grocery) is extreme: Milk at 5.11 standard deviations above average, Grocery at 4.91, Detergents Paper at 4.64, and Delicassen at 3.09. Fresh and Frozen are elevated but less extreme (1.22 and 1.07). Milk is the single strongest distinguishing feature, making it the primary differentiator between the two profiles.
Segment Sizes
Every segment sized, characterized, and illustrated with named members.
| Cluster | N | Share PCT | Top Features | Example Members |
|---|---|---|---|---|
| C1: Near overall average | 434 | 98.6 | Near overall average | 2, 2, 2 |
| C2: High Milk, High Grocery | 6 | 1.4 | High Milk, High Grocery | 2, 2, 2 |
C1 dominates with 434 rows (98.6% of the sample); C2 is a small outlier group with 6 rows (1.4%). The size ratio is 72.3:1, indicating a highly unbalanced split. Both segments are named by their defining traits: C1 represents mainstream spending patterns, C2 a niche of high-volume dairy and grocery buyers. Small-segment profiles should be interpreted cautiously—6 rows is enough to confirm the pattern is real (silhouette backs this), but not enough to price individual members with confidence.
Hierarchical Clustering — Segments With a Family Tree
Agglomerative hierarchical clustering on standardized features: Ward.D2 linkage builds the tree, three linkages are compared by cophenetic correlation, the number of clusters is chosen by average silhouette width, and each segment is sized, profiled, and mapped in 2-D.
Why This Method?
Where k-means demands the number of clusters up front, hierarchical clustering builds the full merge tree first — structure at every scale — and only then cuts it. The merge-height scree shows WHERE the tree naturally separates, and nested sub-segments stay visible instead of being averaged away.
What This Analysis Covers
- Ward.D2 linkage tree on standardized euclidean distances
- Linkage comparison (ward.D2 / complete / average) by cophenetic correlation
- Data-driven cut: average silhouette width over k = 2..min(10, n/20)
- Merge-height scree (the last ~30 merges), cluster profiles as a z-score
heatmap, a 2-D PCA map, and a sizes table with named example members
Standard Library
Platform standard-library module (LAT-1441): runs on ANY dataset via the semantic mapping {base_1..base_N, label}. All narrative is derived from the user's own column names and computed values.
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))Core Analysis Pipeline
compute_shared <- function(df, params, col_map = list()) {
# === SHARED EXPORTS ===
# initial_rows/final_rows/rows_removed $ row accounting
# feature_names $ named character — semantic -> humanized names
# used_features $ character — semantic names used
# dropped_features $ character — excluded columns
# label_name $ character — humanized name of the label column
# labels_vec $ character, length final_rows — row names (label col)
# sampled / sample_n$ whether the 1500-row cap fired, and to how many rows
# coph_df $ data.frame(linkage, cophenetic_correlation)
# best_linkage $ character — linkage preserving distances best
# k_star / sil_star $ chosen k and its average silhouette width
# sil_quality $ character — weak / reasonable / strong
# k_searched $ integer vector — the k values evaluated
# sil_df $ data.frame(k, avg_silhouette) — chart data
# tree_k $ integer — cut suggested by the largest merge gap
# merge_heights_df $ data.frame(clusters_remaining, merge_height) — scree
# assignments $ integer vector (1 = largest cluster)
# cluster_labels $ character(k_star) — auto-generated cluster names
# sizes_table_df $ data.frame(cluster, n, share_pct, top_features,
# example_members)
# share_pct $ numeric(k_star)
# profiles_df $ data.frame(cluster, feature, mean_z) — LONG heatmap
# most_sep_feature $ character — feature separating clusters most
# most_sep_range $ numeric — its cluster-mean range in z units
# map_df $ data.frame(pc1, pc2, cluster) — <=1000 PCA sample
# pc_var_pct $ numeric(2) — % variance of PC1/PC2
# metrics / json_output
# === /SHARED EXPORTS ===Step 1: Discover mapped features + the label column
initial_rows <- nrow(df)
feat_cols <- grep("^base_[0-9]+$", names(df), value = TRUE)
feat_cols <- feat_cols[order(as.integer(sub("^base_", "", feat_cols)))]
if (length(feat_cols) < 2) {
stop("column_mapping must map at least two numeric columns(base_1, base_2)")
}
feature_names <- setNames(humanize_semantic(feat_cols, col_map), feat_cols)
label_name <- humanize_semantic("label", col_map)
labels_raw <- if ("label" %in% names(df)) as.character(df$label) else
rep(NA_character_, initial_rows)
blank_lab <- is.na(labels_raw) | trimws(labels_raw) == ""
labels_raw[blank_lab] <- paste0("Row ", which(blank_lab))Step 2: Coerce numeric (95% rule); impute median; drop unusable
dropped_features <- character(0)
for (fc in feat_cols) {
v <- df[[fc]]
if (!is.numeric(v)) {
conv <- suppressWarnings(as.numeric(as.character(v)))
n_orig <- sum(!is.na(v) & as.character(v) != "")
if (n_orig > 0 && sum(!is.na(conv)) >= 0.95 * n_orig) {
df[[fc]] <- conv
} else {
dropped_features <- c(dropped_features, fc); next
}
}
v <- df[[fc]]
med <- median(v, na.rm = TRUE)
if (is.na(med)) { dropped_features <- c(dropped_features, fc); next }
v[is.na(v)] <- med
df[[fc]] <- v
if (isTRUE(var(v) == 0) || is.na(var(v))) {
dropped_features <- c(dropped_features, fc)
}
}
used_features <- setdiff(feat_cols, dropped_features)
if (length(used_features) < 2) {
stop(paste0(
"Hierarchical clustering needs at least two usable numeric columns; only ",
length(used_features), " of the mapped columns(",
paste(feature_names[feat_cols], collapse = ", "),
") remained after cleaning."))
}
X <- df[, used_features, drop = FALSE]
labels_vec <- labels_raw
if (nrow(X) < 30) {
stop(sprintf(
"Only %d usable rows across %s — hierarchical clustering needs at least 30 rows to find stable segments.",
nrow(X), paste(feature_names[used_features], collapse = ", ")))
}
hn_used <- unname(feature_names[used_features])Step 2b: Cap rows at 1500 (linkage builds an n-by-n distance matrix)
sampled <- FALSE
if (nrow(X) > 1500) {
set.seed(42)
keep_idx <- sort(sample(nrow(X), 1500))
X <- X[keep_idx, , drop = FALSE]
labels_vec <- labels_vec[keep_idx]
sampled <- TRUE
}
final_rows <- nrow(X)
sample_n <- final_rows
rows_removed <- initial_rows - final_rows
n <- final_rowsStep 3: Standardize; build the tree under three linkages;
compare them by cophenetic correlation
Xs <- scale(as.matrix(X))
D <- dist(Xs, method = "euclidean")
hc_ward <- hclust(D, method = "ward.D2")
hc_comp <- hclust(D, method = "complete")
hc_avg <- hclust(D, method = "average")
coph <- vapply(list(hc_ward, hc_comp, hc_avg), function(h) {
suppressWarnings(tryCatch(cor(D, stats::cophenetic(h)),
error = function(e) NA_real_))
}, numeric(1))
linkage_names <- c("ward.D2", "complete", "average")
coph_df <- data.frame(linkage = linkage_names,
cophenetic_correlation = round(coph, 3),
stringsAsFactors = FALSE)LAT-1445 guard: filter NA before which.max
coph_ok <- which(!is.na(coph))
best_linkage <- if (length(coph_ok) > 0) {
linkage_names[coph_ok][which.max(coph[coph_ok])]
} else "ward.D2"Step 4: Choose k by average silhouette width over the Ward tree
k_max <- max(2L, min(10L, floor(n / 20)))
k_searched <- 2:k_max
sil_by_k <- vapply(k_searched, function(k) {
cl <- tryCatch(cutree(hc_ward, k = k), error = function(e) NULL)
if (is.null(cl) || length(unique(cl)) < 2) return(NA_real_)
s <- tryCatch(cluster::silhouette(cl, D), error = function(e) NULL)
if (is.null(s)) return(NA_real_)
mean(s[, 3])
}, numeric(1))LAT-1445 guard: never which.max over a possibly-all-NA vector
valid <- which(!is.na(sil_by_k))
if (length(valid) == 0) {
stop(paste0("No valid cut of the cluster tree could be evaluated on ",
paste(hn_used, collapse = ", "),
" — the data may have too few distinct rows to cluster."))
}
k_star <- k_searched[valid][which.max(sil_by_k[valid])]
sil_star <- max(sil_by_k[valid])
sil_quality <- if (sil_star > 0.5) "strong"
else if (sil_star >= 0.25) "reasonable"
else "weak"
sil_df <- data.frame(k = k_searched[valid],
avg_silhouette = round(sil_by_k[valid], 3),
stringsAsFactors = FALSE)Step 5: Merge-height scree (last ~30 merges) + the tree's own cut
The merge that reduces the data to c clusters has height h[n - c]; a wide gap between successive heights marks a natural cut.
m_steps <- min(30L, n - 1L)
cvals <- seq_len(m_steps)
merge_heights_df <- data.frame(
clusters_remaining = cvals,
merge_height = round(hc_ward$height[n - cvals], 3),
stringsAsFactors = FALSE
)
kg <- 2:min(15L, n - 1L)
gaps <- hc_ward$height[n - kg + 1] - hc_ward$height[n - kg]
gap_ok <- which(!is.na(gaps))
tree_k <- if (length(gap_ok) > 0) kg[gap_ok][which.max(gaps[gap_ok])] else NA_integer_Step 6: Cut at k_star on ward.D2; relabel clusters by size
cl_raw <- cutree(hc_ward, k = k_star)
tab <- tabulate(cl_raw, nbins = k_star)
ord_sz <- order(-tab)
remap <- integer(k_star); remap[ord_sz] <- seq_len(k_star)
assignments <- remap[cl_raw]
sizes <- tabulate(assignments, nbins = k_star)
share_pct <- round(100 * sizes / n, 1)Step 7: Standardized centroids -> names + profiles + separation
centers <- t(vapply(seq_len(k_star), function(ci) {
colMeans(Xs[assignments == ci, , drop = FALSE])
}, numeric(ncol(Xs))))
cluster_desc <- apply(centers, 1, function(cv) {
cv <- as.numeric(cv)
ord <- order(-abs(cv))
if (abs(cv[ord[1]]) < 0.1) return("Near overall average")
part <- function(i) paste0(if (cv[i] > 0) "High " else "Low ", hn_used[i])
parts <- part(ord[1])
if (length(ord) >= 2 && abs(cv[ord[2]]) >= 0.3) {
parts <- c(parts, part(ord[2]))
}
paste(parts, collapse = ", ")
})
cluster_labels <- sprintf("C%d: %s", seq_len(k_star), cluster_desc)Cluster-mean heatmap in z units (LONG: cluster x feature)
prof_rows <- list()
for (ci in seq_len(k_star)) {
for (fi in seq_along(used_features)) {
prof_rows[[length(prof_rows) + 1]] <- data.frame(
cluster = cluster_labels[ci],
feature = hn_used[fi],
mean_z = round(centers[ci, fi], 2),
stringsAsFactors = FALSE
)
}
}
profiles_df <- do.call(rbind, prof_rows)
rownames(profiles_df) <- NULLMost separating feature: widest spread of cluster means in z units
sep_range <- apply(centers, 2, function(cv) diff(range(cv)))
sep_ok <- which(!is.na(sep_range))
if (length(sep_ok) > 0) {
most_sep_feature <- hn_used[sep_ok][which.max(sep_range[sep_ok])]
most_sep_range <- round(max(sep_range[sep_ok]), 2)
} else {
most_sep_feature <- hn_used[1]
most_sep_range <- NA_real_
}Step 8: Sizes table with named example members (the label column)
sizes_table_df <- data.frame(
cluster = cluster_labels,
n = sizes,
share_pct = share_pct,
top_features = unname(cluster_desc),
example_members = vapply(seq_len(k_star), function(ci) {
paste(head(labels_vec[assignments == ci], 3), collapse = ", ")
}, character(1)),
stringsAsFactors = FALSE
)Step 9: 2-D PCA projection colored by cluster (<=1000 sample)
pr <- prcomp(Xs, center = FALSE, scale. = FALSE)
var_all <- pr$sdev^2 / sum(pr$sdev^2)
pc_var_pct <- round(100 * var_all[1:2], 1)
set.seed(42)
map_idx <- if (n > 1000) sample(n, 1000) else seq_len(n)
map_df <- data.frame(
pc1 = round(pr$x[map_idx, 1], 3),
pc2 = round(pr$x[map_idx, 2], 3),
cluster = cluster_labels[assignments[map_idx]],
stringsAsFactors = FALSE
)
metrics <- list(
`Observations` = n,
`Features Used` = length(used_features),
`Clusters Found` = k_star,
`Avg Silhouette` = round(sil_star, 3),
`Separation Quality` = sil_quality,
`Largest Cluster` = paste0(format(sizes[1], big.mark = ","),
" rows(", share_pct[1], "%)"),
`Best-Fit Linkage` = best_linkage
)
json_output <- list(
answer = paste0(
"Hierarchical clustering(Ward.D2 on ", length(used_features),
" standardized features, ", format(n, big.mark = ","), " rows) finds ",
k_star, " natural segments(average silhouette ", round(sil_star, 3),
" — ", sil_quality, " separation; k chosen over k=2..", k_max, "). ",
paste(sprintf("%s: %s rows(%s%%)", cluster_labels,
format(sizes, big.mark = ",", trim = TRUE), share_pct),
collapse = "; "), ". ",
"The feature separating the segments most is ", most_sep_feature,
if (!is.na(most_sep_range)) paste0(
" (cluster means span ", most_sep_range, " standard deviations)") else "",
". Among the linkages compared, ", best_linkage,
" preserved the original distances best(cophenetic correlation)."
),
cards = lapply(
c("tldr", "overview", "preprocessing", "merge_heights",
"silhouette_by_k", "cluster_map", "cluster_profiles",
"cluster_sizes_table"),
function(cid) list(id = cid, metrics = metrics)
)
)
list(
initial_rows = initial_rows, final_rows = final_rows,
rows_removed = rows_removed,
feature_names = feature_names, used_features = used_features,
dropped_features = dropped_features,
label_name = label_name, labels_vec = labels_vec,
sampled = sampled, sample_n = sample_n,
coph_df = coph_df, best_linkage = best_linkage,
k_star = k_star, sil_star = sil_star, sil_quality = sil_quality,
k_searched = k_searched[valid], sil_df = sil_df, tree_k = tree_k,
merge_heights_df = merge_heights_df,
assignments = assignments, cluster_labels = cluster_labels,
sizes_table_df = sizes_table_df, share_pct = share_pct,
profiles_df = profiles_df,
most_sep_feature = most_sep_feature, most_sep_range = most_sep_range,
map_df = map_df, pc_var_pct = pc_var_pct,
metrics = metrics, json_output = json_output
)
}LAT-1445 guard: filter NA before which.max
ok <- which(!is.na(mz))
standout_note <- if (length(ok) > 0) {
top <- pdf[ok[which.max(abs(mz[ok]))], ]
paste0("The single strongest cell: ", top$cluster, " sits ",
abs(top$mean_z), " standard deviations ",
if (top$mean_z > 0) "above" else "below",
" the overall average on ", top$feature, ". ")
} else ""
text <- paste0(
"Each cell shows how far one segment's average sits from the overall ",
"average on one feature, in standard deviations(z-scores, so every ",
"feature is on the same scale). Values near 0 mean the feature does ",
"not distinguish the segment; values beyond about ±1 mark a ",
"defining trait. ", standout_note,
"The feature separating the segments most overall is ",
shared$most_sep_feature, "."
)
list(
title = "Segment Profiles",
description = "Per-segment feature averages in standard-deviation units.",
text = text,
chart_labels = list(
cluster = "Segment",
feature = "Feature",
mean_z = "Mean(z-score)"
),
data = list(cluster_profiles = pdf)
)
}
# Card: cluster_sizes_table (table)
card_cluster_sizes_table <- function(shared, df, params) {
st <- shared$sizes_table_df
sizes <- st$n
balance_note <- if (min(sizes) > 0 && max(sizes) / min(sizes) <= 2) {
"The segments are fairly balanced in size."
} else {
paste0("Sizes are uneven — the largest segment holds ",
round(max(sizes) / max(1, min(sizes)), 1),
"x the rows of the smallest. Small segments can still be the ",
"most valuable ones(niche or outlier groups), but treat their ",
"profile averages with more caution.")
}
text <- paste0(
"Each row is one discovered segment: its size, share, the features ",
"that most distinguish it, and up to three example members named by ",
"the ", shared$label_name, " column. ",
paste(sprintf("%s holds %s rows(%s%%)", st$cluster,
format(sizes, big.mark = ",", trim = TRUE), st$share_pct),
collapse = "; "), ". ", balance_note
)
list(
title = "Segment Sizes",
description = "Every segment sized, characterized, and illustrated with named members.",
text = text,
data = list(cluster_sizes_table = st)
)
}